SUBROUTINE DIFF_PLANCK_SOURCE(N_PROFILE, N_LAYER 1DFPLN3A.23
& , N_DEG_FIT, THERMAL_COEFFICIENT DFPLN3A.24
& , T_REF_PLANCK, T_LEVEL, T_GROUND DFPLN3A.25
& , PLANCK_SOURCE, DIFF_PLANCK, PLANCK_GROUND DFPLN3A.26
& , L_IR_SOURCE_QUAD, T, DIFF_PLANCK_2 DFPLN3A.27
& , N_FRAC_ICE_POINT, I_FRAC_ICE_POINT, ICE_FRACTION ADB1F401.54
& , PLANCK_FREEZE_SEA ADB1F401.55
& , NPD_PROFILE, NPD_LAYER, NPD_THERMAL_COEFF DFPLN3A.28
& ) DFPLN3A.29
! DFPLN3A.30
! DFPLN3A.31
IMPLICIT NONE DFPLN3A.32
! DFPLN3A.33
! DFPLN3A.34
! DUMMY ARRAY SIZES DFPLN3A.35
INTEGER !, INTENT(IN) DFPLN3A.36
& NPD_PROFILE DFPLN3A.37
! MAXIMUM NUMBER OF PROFILES DFPLN3A.38
& , NPD_LAYER DFPLN3A.39
! MAXIMUM NUMBER OF LAYERS DFPLN3A.40
& , NPD_THERMAL_COEFF DFPLN3A.41
! NUMBER OF THERMAL COEFFICIENTS DFPLN3A.42
! DFPLN3A.43
! COMDECKS INCLUDED. ADB1F401.56
*CALL C_0_DG_C 
ADB1F401.57
! ADB1F401.58
! DUMMY ARGUMENTS. DFPLN3A.44
INTEGER !, INTENT(IN) DFPLN3A.45
& N_PROFILE DFPLN3A.46
! NUMBER OF PROFILES DFPLN3A.47
& , N_LAYER DFPLN3A.48
! NUMBER OF LAYERS DFPLN3A.49
& , N_DEG_FIT DFPLN3A.50
! DEGREE OF FITTING FUNCTION DFPLN3A.51
LOGICAL !, INTENT(IN) DFPLN3A.52
& L_IR_SOURCE_QUAD DFPLN3A.53
! IR-SOURCE QUADRATIC DFPLN3A.54
REAL !, INTENT(IN) DFPLN3A.55
& THERMAL_COEFFICIENT(0: NPD_THERMAL_COEFF-1) DFPLN3A.56
! COEFFICIENTS OF FIT TO PLANCK FNC DFPLN3A.57
& , T_REF_PLANCK DFPLN3A.58
! PLANCKIAN REFERENCE TEMPERATURE DFPLN3A.59
& , T_LEVEL(NPD_PROFILE, 0: NPD_LAYER) DFPLN3A.60
! TEMPERATURES ON LEVELS DFPLN3A.61
& , T_GROUND(NPD_PROFILE) DFPLN3A.62
! TEMPERATURES AT GROUND DFPLN3A.63
REAL !, INTENT(OUT) DFPLN3A.64
& PLANCK_SOURCE(NPD_PROFILE, 0: NPD_LAYER) DFPLN3A.65
! PLANCK FUNCTION ON LEVELS DFPLN3A.66
& , DIFF_PLANCK(NPD_PROFILE, NPD_LAYER) DFPLN3A.67
! DIFFERENCES IN PLANCKIAN FNC DFPLN3A.68
& , DIFF_PLANCK_2(NPD_PROFILE, NPD_LAYER) DFPLN3A.69
! TWICE 2ND DIFFERENCES IN PLANCKIAN FUNCTION DFPLN3A.70
& , T(NPD_PROFILE, 0: NPD_LAYER) DFPLN3A.71
! TEMPERATURES AT CENTRES OF LAYERS DFPLN3A.72
& , PLANCK_GROUND(NPD_PROFILE) DFPLN3A.73
! PLANCKIAN FUNCTION AT GROUND DFPLN3A.74
! DFPLN3A.75
! ARGUMENTS RELATING TO SEA ICE. ADB1F401.59
INTEGER !, INTENT(IN) ADB1F401.60
& N_FRAC_ICE_POINT ADB1F401.61
! NUMBER OF POINTS WITH FRACTIONAL ICE COVER ADB1F401.62
& , I_FRAC_ICE_POINT(NPD_PROFILE) ADB1F401.63
! INDICES OF POINTS WITH FRACTIONAL ICE COVER ADB1F401.64
REAL !, INTENT(IN) ADB1F401.65
& ICE_FRACTION(NPD_PROFILE) ADB1F401.66
! ICE FRACTION ADB1F401.67
! ADB1F401.68
REAL !, INTENT(OUT) ADB1F401.69
& PLANCK_FREEZE_SEA ADB1F401.70
! PLANCK FUNCTION OVER FREEZING SEA ADB1F401.71
! ADB1F401.72
! ADB1F401.73
! LOCAL VARIABLES. DFPLN3A.76
INTEGER DFPLN3A.77
& I DFPLN3A.78
! LOOP VARIABLE DFPLN3A.79
& , J DFPLN3A.80
! LOOP VARIABLE DFPLN3A.81
& , L DFPLN3A.82
! LOOP VARIABLE DFPLN3A.83
REAL DFPLN3A.84
& T_RATIO(NPD_PROFILE) DFPLN3A.85
! TEMPERATURE RATIO DFPLN3A.86
! ADB1F401.74
! VARIABLES FOR FRACTIONAL ICE COVER. ADB1F401.75
INTEGER ADB1F401.76
& LG ADB1F401.77
! GATHERED LOOP VARIABLE ADB1F401.78
REAL ADB1F401.79
& T_ICE_G(NPD_PROFILE) ADB1F401.80
! TEMPERATURE OF ICE SURFACE (GATHERED OVER SEA-ICE POINTS) ADB1F401.81
& , PLANCK_GROUND_G(NPD_PROFILE) ADB1F401.82
! PLANCKIAN OF ICE SURFACE (GATHERED OVER SEA-ICE POINTS) ADB1F401.83
ADB1F401.84
ADB1F401.85
! ADB1F401.86
! DFPLN3A.87
! DFPLN3A.88
! CALCULATE THE CHANGE IN THE THERMAL SOURCE FUNCTION DFPLN3A.89
! ACROSS EACH LAYER FOR THE INFRA-RED PART OF THE SPECTRUM. DFPLN3A.90
DO L=1, N_PROFILE DFPLN3A.91
T_RATIO(L)=T_LEVEL(L, 0)/T_REF_PLANCK DFPLN3A.92
PLANCK_SOURCE(L, 0) DFPLN3A.93
& =THERMAL_COEFFICIENT(N_DEG_FIT) DFPLN3A.94
ENDDO DFPLN3A.95
DO J=N_DEG_FIT-1, 0, -1 DFPLN3A.96
DO L=1, N_PROFILE DFPLN3A.97
PLANCK_SOURCE(L, 0) DFPLN3A.98
& =PLANCK_SOURCE(L, 0) DFPLN3A.99
& *T_RATIO(L)+THERMAL_COEFFICIENT(J) DFPLN3A.100
ENDDO DFPLN3A.101
ENDDO DFPLN3A.102
DO I=1, N_LAYER DFPLN3A.103
DO L=1, N_PROFILE DFPLN3A.104
T_RATIO(L)=T_LEVEL(L, I)/T_REF_PLANCK DFPLN3A.105
PLANCK_SOURCE(L, I) DFPLN3A.106
& =THERMAL_COEFFICIENT(N_DEG_FIT) DFPLN3A.107
ENDDO DFPLN3A.108
DO J=N_DEG_FIT-1, 0, -1 DFPLN3A.109
DO L=1, N_PROFILE DFPLN3A.110
PLANCK_SOURCE(L, I) DFPLN3A.111
& =PLANCK_SOURCE(L, I) DFPLN3A.112
& *T_RATIO(L)+THERMAL_COEFFICIENT(J) DFPLN3A.113
ENDDO DFPLN3A.114
ENDDO DFPLN3A.115
DO L=1, N_PROFILE DFPLN3A.116
DIFF_PLANCK(L, I)=PLANCK_SOURCE(L, I) DFPLN3A.117
& -PLANCK_SOURCE(L, I-1) DFPLN3A.118
ENDDO DFPLN3A.119
ENDDO DFPLN3A.120
! CALCULATE THE SECOND DIFFERENCE IF REQUIRED. DFPLN3A.121
IF (L_IR_SOURCE_QUAD) THEN DFPLN3A.122
DO I=1, N_LAYER DFPLN3A.123
! USE THE SECOND DIFFERENCE FOR TEMPORARY STORAGE. DFPLN3A.124
! OF THE PLANCKIAN AT THE MIDDLE OF THE LAYER. DFPLN3A.125
DO L=1, N_PROFILE DFPLN3A.126
T_RATIO(L)=T(L, I)/T_REF_PLANCK DFPLN3A.127
DIFF_PLANCK_2(L, I) DFPLN3A.128
& =THERMAL_COEFFICIENT(N_DEG_FIT) DFPLN3A.129
ENDDO DFPLN3A.130
DO J=N_DEG_FIT-1, 0, -1 DFPLN3A.131
DO L=1, N_PROFILE DFPLN3A.132
DIFF_PLANCK_2(L, I) DFPLN3A.133
& =DIFF_PLANCK_2(L, I) DFPLN3A.134
& *T_RATIO(L)+THERMAL_COEFFICIENT(J) DFPLN3A.135
ENDDO DFPLN3A.136
ENDDO DFPLN3A.137
DO L=1, N_PROFILE DFPLN3A.138
DIFF_PLANCK_2(L, I)=2.0E+00*(PLANCK_SOURCE(L, I) DFPLN3A.139
& +PLANCK_SOURCE(L, I-1)-2.0E+00*DIFF_PLANCK_2(L, I)) DFPLN3A.140
ENDDO DFPLN3A.141
ENDDO DFPLN3A.142
ENDIF DFPLN3A.143
! DFPLN3A.144
! SOURCE AT THE SURFACE. DFPLN3A.145
DO L=1, N_PROFILE DFPLN3A.146
T_RATIO(L)=T_GROUND(L)/T_REF_PLANCK DFPLN3A.147
PLANCK_GROUND(L)=THERMAL_COEFFICIENT(N_DEG_FIT) DFPLN3A.148
ENDDO DFPLN3A.149
DO J=N_DEG_FIT-1, 0, -1 DFPLN3A.150
DO L=1, N_PROFILE DFPLN3A.151
PLANCK_GROUND(L)=PLANCK_GROUND(L)*T_RATIO(L) DFPLN3A.152
& +THERMAL_COEFFICIENT(J) DFPLN3A.153
ENDDO DFPLN3A.154
ENDDO DFPLN3A.155
! ADB1F401.87
! WHERE THERE IS FRACTIONAL SEA-ICE THE FORMULATION MUST BE ADB1F401.88
! EXTENDED, BUT IT IS CONVENIENT TO CARRY OUT THE ABOVE OPERATION ADB1F401.89
! AT ALL POINTS TO AVOID THE USE OF INDIRECT ADDRESSING. ADB1F401.90
! ADB1F401.91
! CALCULATE THE SOURCE FUNCTION OVER OPEN SEA, ADOPTING THE MODEL'S ADB1F401.92
! CONVENTION THAT THE TEMPAERTURE THERE IS FIXED. ADB1F401.93
T_RATIO(1)=TFS/T_REF_PLANCK ADB1F401.94
PLANCK_FREEZE_SEA=THERMAL_COEFFICIENT(N_DEG_FIT) ADB1F401.95
DO J=N_DEG_FIT-1, 0, -1 ADB1F401.96
PLANCK_FREEZE_SEA=PLANCK_FREEZE_SEA*T_RATIO(1) ADB1F401.97
& +THERMAL_COEFFICIENT(J) ADB1F401.98
ENDDO ADB1F401.99
! ADB1F401.100
! DETERMINE THE TEMPERATURE OF THE ICE. ADB1F401.101
DO L=1, N_FRAC_ICE_POINT ADB1F401.102
LG=I_FRAC_ICE_POINT(L) ADB1F401.103
T_ICE_G(L)=(T_GROUND(LG) ADB1F401.104
& -TFS*(1.0E+00-ICE_FRACTION(LG)))/ICE_FRACTION(LG) ADB1F401.105
ENDDO ADB1F401.106
! ADB1F401.107
! CALCULATE THE SOURCE FUNCTION AT POINTS WITH FRACTIONAL ICE. ADB1F401.108
DO L=1, N_FRAC_ICE_POINT ADB1F401.109
T_RATIO(L)=T_ICE_G(L)/T_REF_PLANCK ADB1F401.110
PLANCK_GROUND_G(L)=THERMAL_COEFFICIENT(N_DEG_FIT) ADB1F401.111
ENDDO ADB1F401.112
DO J=N_DEG_FIT-1, 0, -1 ADB1F401.113
DO L=1, N_FRAC_ICE_POINT ADB1F401.114
PLANCK_GROUND_G(L)=PLANCK_GROUND_G(L)*T_RATIO(L) ADB1F401.115
& +THERMAL_COEFFICIENT(J) ADB1F401.116
ENDDO ADB1F401.117
ENDDO ADB1F401.118
! ADB1F401.119
! DETERMINE THE OVERALL PLANCKIAN FUNCTION OF THE SURFACE. ADB1F401.120
DO L=1, N_FRAC_ICE_POINT ADB1F401.121
LG=I_FRAC_ICE_POINT(L) ADB1F401.122
PLANCK_GROUND(LG)=ICE_FRACTION(LG)*PLANCK_GROUND_G(L) ADB1F401.123
& +PLANCK_FREEZE_SEA*(1.0E+00-ICE_FRACTION(LG)) ADB1F401.124
ENDDO ADB1F401.125
! ADB1F401.126
! DFPLN3A.156
! DFPLN3A.157
RETURN DFPLN3A.158
END DFPLN3A.159
*ENDIF DEF,A01_3A,OR,DEF,A02_3A DFPLN3A.160
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.18