SUBROUTINE OPT_PROP_ICE_CLOUD(IERR 2OPICL3A.24
& , N_PROFILE, N_LAYER, N_CLOUD_TOP OPICL3A.25
& , N_CLOUD_PROFILE, I_CLOUD_PROFILE OPICL3A.26
& , L_RESCALE, L_LAYER, L_CLOUD_LAYER OPICL3A.27
& , I_PARAMETRIZATION_ICE, ICE_CLOUD_PARAMETER OPICL3A.28
& , ICE_MASS_FRAC, DIM_CHAR_ICE ADB2F404.834
& , T, DENSITY OPICL3A.30
& , K_EXT_TOT_CLOUD, K_EXT_SCAT_CLOUD OPICL3A.31
& , ASYMMETRY_CLOUD, FORWARD_SCATTER_CLOUD OPICL3A.32
& , NPD_PROFILE, NPD_LAYER OPICL3A.33
& , NPD_CLOUD_PARAMETER OPICL3A.34
& ) OPICL3A.35
! OPICL3A.36
! OPICL3A.37
IMPLICIT NONE OPICL3A.38
! OPICL3A.39
! OPICL3A.40
INTEGER !, INTENT(IN) OPICL3A.41
& NPD_PROFILE OPICL3A.42
! MAXIMUM NUMBER OF PROFILES OPICL3A.43
& , NPD_LAYER OPICL3A.44
! MAXIMUM NUMBER OF LAYERS OPICL3A.45
& , NPD_CLOUD_PARAMETER OPICL3A.46
! MAXIMUM NUMBER OF CLOUD PARAMETERS OPICL3A.47
! OPICL3A.48
! INCLUDE COMDECKS OPICL3A.49
*CALL STDIO3A 
OPICL3A.50
*CALL ICLPRM3A OPICL3A.51
*CALL ERROR3A OPICL3A.52
! OPICL3A.53
! DUMMY VARIABLES. OPICL3A.54
INTEGER !, INTENT(OUT) OPICL3A.55
& IERR OPICL3A.56
! ERROR FLAG OPICL3A.57
INTEGER !, INTENT(IN) OPICL3A.58
& N_PROFILE OPICL3A.59
! NUMBER OF PROFILES OPICL3A.60
& , N_LAYER OPICL3A.61
! NUMBER OF LAYERS OPICL3A.62
& , N_CLOUD_TOP OPICL3A.63
! TOPMOST CLOUDY LAYER OPICL3A.64
& , I_PARAMETRIZATION_ICE OPICL3A.65
! TREATMENT OF ICE CRYSTALS OPICL3A.66
& , N_CLOUD_PROFILE(NPD_LAYER) OPICL3A.67
! NUMBER OF CLOUDY PROFILES OPICL3A.68
& , I_CLOUD_PROFILE(NPD_PROFILE, NPD_LAYER) OPICL3A.69
! PROFILES CONTAINING CLOUDS OPICL3A.70
LOGICAL !, INTENT(IN) OPICL3A.71
& L_LAYER OPICL3A.72
! VARIABLES GIVEN IN LAYERS OPICL3A.73
& , L_CLOUD_LAYER OPICL3A.74
! CLOUD VARIABLES GIVEN IN LAYERS OPICL3A.75
& , L_RESCALE OPICL3A.76
! DELTA-RESCALING REQUIRED OPICL3A.77
REAL !, INTENT(IN) OPICL3A.78
& ICE_CLOUD_PARAMETER(NPD_CLOUD_PARAMETER) OPICL3A.79
! ICE CLOUD PARAMETERS OPICL3A.80
& , ICE_MASS_FRAC(NPD_PROFILE, 0: NPD_LAYER) OPICL3A.81
! ICE MASS FRACTION OPICL3A.82
& , DIM_CHAR_ICE(NPD_PROFILE, 0: NPD_LAYER) ADB2F404.835
! CHARACTERISTIC DIMENSION FOR CRYSTALS ADB2F404.836
& , T(NPD_PROFILE, 0: NPD_LAYER) OPICL3A.85
! TEMPERATURE OPICL3A.86
& , DENSITY(NPD_PROFILE, 0: NPD_LAYER) OPICL3A.87
! DENSITY AT LEVELS OPICL3A.88
REAL !, INTENT(OUT) OPICL3A.89
& K_EXT_SCAT_CLOUD(NPD_PROFILE, NPD_LAYER) OPICL3A.90
! SCATTERING EXTINCTION OPICL3A.91
& , K_EXT_TOT_CLOUD(NPD_PROFILE, NPD_LAYER) OPICL3A.92
! TOTAL EXTINCTION OPICL3A.93
& , ASYMMETRY_CLOUD(NPD_PROFILE, NPD_LAYER) OPICL3A.94
! CLOUDY ASYMMETRIES OPICL3A.95
& , FORWARD_SCATTER_CLOUD(NPD_PROFILE, NPD_LAYER) OPICL3A.96
! CLOUDY FORWARD SCATTERING OPICL3A.97
! OPICL3A.98
! LOCAL VARIABLES. OPICL3A.99
INTEGER OPICL3A.100
& L OPICL3A.101
! LOOP VARIABLE OPICL3A.102
& , LL OPICL3A.103
! LOOP VARIABLE OPICL3A.104
& , I OPICL3A.105
! LOOP VARIABLE OPICL3A.106
REAL OPICL3A.107
& ASYMMETRY_PROCESS(NPD_PROFILE) OPICL3A.108
! ASYMMETRY FACTOR FOR CURRENT PROC. OPICL3A.109
& , DIM_CHAR_AVE ADB2F404.837
! AVERAGE CHARACTERISTIC DIMENSION IN LAYER ADB2F404.838
& , X ADB2F404.839
! TEMPORARY ALGEBRAIC VARIABLE ADB2F404.840
& , ICE_MASS_FRAC_AVE OPICL3A.112
! AVERAGE ICE MASS FRACTION OPICL3A.113
& , DENSITY_AVE OPICL3A.114
! AVERAGE DENSITY OPICL3A.115
& , T_CELSIUS OPICL3A.120
! TEMPERATURE IN CELSIUS OPICL3A.121
& , TEMP_CORRECTION OPICL3A.122
! TEMPERATURE CORRECTION OPICL3A.123
! OPICL3A.124
! OPICL3A.125
! OPICL3A.126
! OPICL3A.127
IF (I_PARAMETRIZATION_ICE.EQ.IP_SLINGO_SCHRECKER_ICE) THEN OPICL3A.128
! OPICL3A.129
! WE CALCULATE AVERAGE PROPERTIES FOR THE LAYER AND PUT THESE OPICL3A.130
! INTO THE PARAMETRIZATION, RATHER THAN CALCULATING THE OPICL3A.131
! PARAMETRIZATION AT EACH LEVEL: USUALLY THIS IS MORE ACCURATE. OPICL3A.132
! IT ALSO FITS MORE NATURALLY WITH CASES WHERE DATA ARE GIVEN OPICL3A.133
! IN LAYERS. OPICL3A.134
! OPICL3A.135
! THE TOTAL EXTINCTIONS SHOULD BE INCREMENTED BY THE TOTAL OPICL3A.136
! CONTRIBUTIONS FROM CLOUDS, NOT JUST BY THE ABSORPTIVE OPICL3A.137
! EXTINCTIONS. OPICL3A.138
! OPICL3A.139
DO I=N_CLOUD_TOP, N_LAYER OPICL3A.140
DO LL=1, N_CLOUD_PROFILE(I) OPICL3A.141
L=I_CLOUD_PROFILE(LL, I) OPICL3A.142
ICE_MASS_FRAC_AVE=ICE_MASS_FRAC(L, I) OPICL3A.143
DIM_CHAR_AVE=DIM_CHAR_ICE(L, I) ADB2F404.841
K_EXT_TOT_CLOUD(L, I) OPICL3A.145
& =ICE_MASS_FRAC_AVE*(ICE_CLOUD_PARAMETER(1) OPICL3A.146
& +ICE_CLOUD_PARAMETER(2)/DIM_CHAR_AVE) ADB2F404.842
K_EXT_SCAT_CLOUD(L, I)=K_EXT_TOT_CLOUD(L, I) OPICL3A.148
& *(1.0E+00-ICE_CLOUD_PARAMETER(3) OPICL3A.149
& -ICE_CLOUD_PARAMETER(4)*DIM_CHAR_AVE) ADB2F404.843
ASYMMETRY_PROCESS(L)= OPICL3A.151
& ICE_CLOUD_PARAMETER(5)+ICE_CLOUD_PARAMETER(6) OPICL3A.152
& *DIM_CHAR_AVE ADB2F404.844
ASYMMETRY_CLOUD(L, I)= OPICL3A.154
& K_EXT_SCAT_CLOUD(L, I)*ASYMMETRY_PROCESS(L) OPICL3A.155
ENDDO OPICL3A.156
IF (L_RESCALE) THEN OPICL3A.157
DO LL=1, N_CLOUD_PROFILE(I) OPICL3A.158
L=I_CLOUD_PROFILE(LL, I) OPICL3A.159
FORWARD_SCATTER_CLOUD(L, I) OPICL3A.160
& =K_EXT_SCAT_CLOUD(L, I) OPICL3A.161
& *ASYMMETRY_PROCESS(L)**2 OPICL3A.162
ENDDO OPICL3A.163
ENDIF OPICL3A.164
ENDDO OPICL3A.165
! OPICL3A.166
ELSE IF (I_PARAMETRIZATION_ICE.EQ.IP_ICE_ADT) THEN ADB2F404.845
! OPICL3A.168
DO I=N_CLOUD_TOP, N_LAYER OPICL3A.169
DO LL=1, N_CLOUD_PROFILE(I) OPICL3A.170
L=I_CLOUD_PROFILE(LL, I) OPICL3A.171
ICE_MASS_FRAC_AVE=ICE_MASS_FRAC(L, I) OPICL3A.172
DIM_CHAR_AVE=DIM_CHAR_ICE(L, I) ADB2F404.846
X=LOG(DIM_CHAR_AVE/ICE_CLOUD_PARAMETER(10)) ADB2F404.847
IF (X.GT.0.0E+00) THEN ADB2F404.848
! LARGE MODE. ADB2F404.849
K_EXT_TOT_CLOUD(L, I)=ICE_MASS_FRAC_AVE ADB2F404.850
& *EXP(ICE_CLOUD_PARAMETER(1) ADB2F404.851
& +X*(ICE_CLOUD_PARAMETER(2) ADB2F404.852
& +X*(ICE_CLOUD_PARAMETER(3) ADB2F404.853
& +X*(ICE_CLOUD_PARAMETER(4) ADB2F404.854
& +X*ICE_CLOUD_PARAMETER(5))))) ADB2F404.855
ELSE ADB2F404.856
! SMALL MODE. ADB2F404.857
K_EXT_TOT_CLOUD(L, I)=ICE_MASS_FRAC_AVE ADB2F404.858
& *EXP(ICE_CLOUD_PARAMETER(1) ADB2F404.859
& +X*(ICE_CLOUD_PARAMETER(6) ADB2F404.860
& +X*(ICE_CLOUD_PARAMETER(7) ADB2F404.861
& +X*(ICE_CLOUD_PARAMETER(8) ADB2F404.862
& +X*ICE_CLOUD_PARAMETER(9))))) ADB2F404.863
ENDIF ADB2F404.864
X=LOG(DIM_CHAR_AVE/ICE_CLOUD_PARAMETER(20)) ADB2F404.865
IF (X.GT.0.0E+00) THEN ADB2F404.866
! LARGE MODE. ADB2F404.867
K_EXT_SCAT_CLOUD(L, I)=K_EXT_TOT_CLOUD(L, I) ADB2F404.868
& *(1.0E+00-(ICE_CLOUD_PARAMETER(11) ADB2F404.869
& +X*(ICE_CLOUD_PARAMETER(12) ADB2F404.870
& +X*(ICE_CLOUD_PARAMETER(13) ADB2F404.871
& +X*(ICE_CLOUD_PARAMETER(14) ADB2F404.872
& +X*ICE_CLOUD_PARAMETER(15)))))) ADB2F404.873
ELSE ADB2F404.874
! SMALL MODE. ADB2F404.875
K_EXT_SCAT_CLOUD(L, I)=K_EXT_TOT_CLOUD(L, I) ADB2F404.876
& *(1.0E+00-(ICE_CLOUD_PARAMETER(11) ADB2F404.877
& +X*(ICE_CLOUD_PARAMETER(16) ADB2F404.878
& +X*(ICE_CLOUD_PARAMETER(17) ADB2F404.879
& +X*(ICE_CLOUD_PARAMETER(18) ADB2F404.880
& +X*ICE_CLOUD_PARAMETER(19)))))) ADB2F404.881
ENDIF ADB2F404.882
X=LOG(DIM_CHAR_AVE/ICE_CLOUD_PARAMETER(30)) ADB2F404.883
IF (X.GT.0.0E+00) THEN ADB2F404.884
! LARGE MODE. ADB2F404.885
ASYMMETRY_PROCESS(L)=ICE_CLOUD_PARAMETER(21) ADB2F404.886
& +X*(ICE_CLOUD_PARAMETER(22) ADB2F404.887
& +X*(ICE_CLOUD_PARAMETER(23) ADB2F404.888
& +X*(ICE_CLOUD_PARAMETER(24) ADB2F404.889
& +X*ICE_CLOUD_PARAMETER(25)))) ADB2F404.890
ELSE ADB2F404.891
! SMALL MODE. ADB2F404.892
ASYMMETRY_PROCESS(L)=ICE_CLOUD_PARAMETER(21) ADB2F404.893
& +X*(ICE_CLOUD_PARAMETER(26) ADB2F404.894
& +X*(ICE_CLOUD_PARAMETER(27) ADB2F404.895
& +X*(ICE_CLOUD_PARAMETER(28) ADB2F404.896
& +X*ICE_CLOUD_PARAMETER(29)))) ADB2F404.897
ENDIF ADB2F404.898
ASYMMETRY_CLOUD(L, I)= OPICL3A.184
& K_EXT_SCAT_CLOUD(L, I)*ASYMMETRY_PROCESS(L) ADB2F404.899
ENDDO OPICL3A.186
IF (L_RESCALE) THEN OPICL3A.187
DO LL=1, N_CLOUD_PROFILE(I) OPICL3A.188
L=I_CLOUD_PROFILE(LL, I) OPICL3A.189
FORWARD_SCATTER_CLOUD(L, I) OPICL3A.190
& =K_EXT_SCAT_CLOUD(L, I) ADB2F404.900
& *ASYMMETRY_PROCESS(L)**2 ADB2F404.901
ENDDO OPICL3A.192
ENDIF OPICL3A.193
ENDDO OPICL3A.194
! OPICL3A.195
! OPICL3A.196
ELSE IF (I_PARAMETRIZATION_ICE.EQ.IP_SUN_SHINE_VN2_VIS) THEN OPICL3A.197
! OPICL3A.198
DO I=N_CLOUD_TOP, N_LAYER OPICL3A.199
DO LL=1, N_CLOUD_PROFILE(I) OPICL3A.200
L=I_CLOUD_PROFILE(LL, I) OPICL3A.201
ICE_MASS_FRAC_AVE=ICE_MASS_FRAC(L, I) OPICL3A.202
DENSITY_AVE=DENSITY(L, I) OPICL3A.203
T_CELSIUS=T(L, I)-2.7316E+02 OPICL3A.204
TEMP_CORRECTION=1.047E+00+T_CELSIUS*(-9.13E-05+T_CELSIUS OPICL3A.205
& *(2.026E-04-1.056E-05*T_CELSIUS)) OPICL3A.206
K_EXT_TOT_CLOUD(L, I)=TEMP_CORRECTION*ICE_MASS_FRAC_AVE OPICL3A.207
& /(3.05548E-02 OPICL3A.208
& +2.54802E+02*DENSITY_AVE*ICE_MASS_FRAC_AVE) OPICL3A.209
K_EXT_SCAT_CLOUD(L, I)=K_EXT_TOT_CLOUD(L, I) OPICL3A.210
& *(1.0E+00-ICE_CLOUD_PARAMETER(1) OPICL3A.211
& *EXP(ICE_CLOUD_PARAMETER(2) OPICL3A.212
& *LOG(DENSITY_AVE*ICE_MASS_FRAC_AVE+1.0E-12))) OPICL3A.213
& *(1.0E+00+ICE_CLOUD_PARAMETER(5) OPICL3A.214
& *(TEMP_CORRECTION-1.0E+00)/TEMP_CORRECTION) OPICL3A.215
ASYMMETRY_PROCESS(L)= OPICL3A.216
& ICE_CLOUD_PARAMETER(3)*EXP(ICE_CLOUD_PARAMETER(4) OPICL3A.217
& *LOG(DENSITY_AVE*ICE_MASS_FRAC_AVE+1.0E-12)) OPICL3A.218
& *(1.0E+00+ICE_CLOUD_PARAMETER(6) OPICL3A.219
& *(TEMP_CORRECTION-1.0E+00)/TEMP_CORRECTION) OPICL3A.220
ASYMMETRY_CLOUD(L, I)= OPICL3A.221
& K_EXT_SCAT_CLOUD(L, I)*ASYMMETRY_PROCESS(L) OPICL3A.222
ENDDO OPICL3A.223
IF (L_RESCALE) THEN OPICL3A.224
DO LL=1, N_CLOUD_PROFILE(I) OPICL3A.225
L=I_CLOUD_PROFILE(LL, I) OPICL3A.226
FORWARD_SCATTER_CLOUD(L, I) OPICL3A.227
& =K_EXT_SCAT_CLOUD(L, I) OPICL3A.228
& *ASYMMETRY_PROCESS(L)**2 OPICL3A.229
ENDDO OPICL3A.230
ENDIF OPICL3A.231
ENDDO OPICL3A.232
! OPICL3A.233
ELSE IF (I_PARAMETRIZATION_ICE.EQ.IP_SUN_SHINE_VN2_IR) THEN OPICL3A.234
! OPICL3A.235
DO I=N_CLOUD_TOP, N_LAYER OPICL3A.236
DO LL=1, N_CLOUD_PROFILE(I) OPICL3A.237
L=I_CLOUD_PROFILE(LL, I) OPICL3A.238
ICE_MASS_FRAC_AVE=ICE_MASS_FRAC(L, I) OPICL3A.239
DENSITY_AVE=DENSITY(L, I) OPICL3A.240
T_CELSIUS=T(L, I)-2.7316E+02 OPICL3A.241
TEMP_CORRECTION=1.047E+00+T_CELSIUS*(-9.13E-05+T_CELSIUS OPICL3A.242
& *(2.026E-04-1.056E-05*T_CELSIUS)) OPICL3A.243
K_EXT_TOT_CLOUD(L, I)=TEMP_CORRECTION*ICE_MASS_FRAC_AVE OPICL3A.244
& /(6.30689E-02 OPICL3A.245
& +2.65874E+02*DENSITY_AVE*ICE_MASS_FRAC_AVE) OPICL3A.246
ENDDO OPICL3A.247
ENDDO OPICL3A.248
! OPICL3A.249
ELSE OPICL3A.250
WRITE(IU_ERR, '(/A)') '*** ERROR: AN INVALID PARAMETRIZATION ' OPICL3A.251
& //'OF ICE CRYSTALS HAS BEEN USED..' OPICL3A.252
IERR=I_ERR_FATAL OPICL3A.253
RETURN OPICL3A.254
ENDIF OPICL3A.255
! ADB2F404.902
! OPICL3A.256
! OPICL3A.257
RETURN OPICL3A.258
END OPICL3A.259
*ENDIF DEF,A01_3A,OR,DEF,A02_3A OPICL3A.260
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.58