*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.59
*IF DEF,A01_3A,OR,DEF,A02_3A OPWCL3A.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13603
C GTS2F400.13604
C Use, duplication or disclosure of this code is subject to the GTS2F400.13605
C restrictions as set forth in the contract. GTS2F400.13606
C GTS2F400.13607
C Meteorological Office GTS2F400.13608
C London Road GTS2F400.13609
C BRACKNELL GTS2F400.13610
C Berkshire UK GTS2F400.13611
C RG12 2SZ GTS2F400.13612
C GTS2F400.13613
C If no contract has been raised with this copy of the code, the use, GTS2F400.13614
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13615
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13616
C Modelling at the above address. GTS2F400.13617
C ******************************COPYRIGHT****************************** GTS2F400.13618
C GTS2F400.13619
!+ Subroutine to calculate optical properties of water clouds. OPWCL3A.3
! OPWCL3A.4
! Method: OPWCL3A.5
! If the optical properties come from an observational OPWCL3A.6
! distribution a separate subroutine is called. Otherwise ADB1F401.721
! appropriate mean quantities in the layer are calculated OPWCL3A.8
! as the parametrization requires and these values are OPWCL3A.9
! substituted into the parametrization to give the optical OPWCL3A.10
! properties. OPWCL3A.11
! OPWCL3A.12
! Current Owner of Code: J. M. Edwards OPWCL3A.13
! OPWCL3A.14
! History: OPWCL3A.15
! Version Date Comment OPWCL3A.16
! 4.0 27-07-95 Original Code OPWCL3A.17
! (J. M. Edwards) OPWCL3A.18
! 4.2 Oct. 96 T3E migration: HF functions GSS3F402.243
! replaced by T3E vec_lib function GSS3F402.244
! rtor_v (S.J.Swarbrick) GSS3F402.245
! 4.5 18-05-98 New parametrization ADB1F405.399
! of the optical ADB1F405.400
! properties of cloud ADB1F405.401
! droplets added. ADB1F405.402
! (J. M. Edwards) ADB1F405.403
! OPWCL3A.19
! Description of Code: OPWCL3A.20
! FORTRAN 77 with extensions listed in documentation. OPWCL3A.21
! OPWCL3A.22
!- --------------------------------------------------------------------- OPWCL3A.23
SUBROUTINE OPT_PROP_WATER_CLOUD(IERR 2OPWCL3A.24
& , N_PROFILE, N_LAYER, N_CLOUD_TOP OPWCL3A.25
& , N_CLOUD_PROFILE, I_CLOUD_PROFILE OPWCL3A.26
& , L_RESCALE, L_LAYER, L_CLOUD_LAYER OPWCL3A.27
& , I_PARAMETRIZATION_DROP, CLOUD_PARAMETER OPWCL3A.28
& , LIQ_WATER_MASS_FRAC, RADIUS_EFFECT OPWCL3A.29
& , K_EXT_TOT_CLOUD, K_EXT_SCAT_CLOUD OPWCL3A.30
& , ASYMMETRY_CLOUD, FORWARD_SCATTER_CLOUD OPWCL3A.31
& , NPD_PROFILE, NPD_LAYER OPWCL3A.32
& , NPD_CLOUD_PARAMETER OPWCL3A.33
& ) OPWCL3A.34
! OPWCL3A.35
! OPWCL3A.36
IMPLICIT NONE OPWCL3A.37
! OPWCL3A.38
! OPWCL3A.39
INTEGER !, INTENT(IN) OPWCL3A.40
& NPD_PROFILE OPWCL3A.41
! MAXIMUM NUMBER OF PROFILES OPWCL3A.42
& , NPD_LAYER OPWCL3A.43
! MAXIMUM NUMBER OF LAYERS OPWCL3A.44
& , NPD_CLOUD_PARAMETER OPWCL3A.45
! MAXIMUM NUMBER OF CLOUD PARAMETERS OPWCL3A.46
! OPWCL3A.47
! INCLUDE COMDECKS OPWCL3A.48
*CALL STDIO3A 
OPWCL3A.49
*CALL WCLPRM3A OPWCL3A.50
*CALL ERROR3A OPWCL3A.51
! OPWCL3A.52
! DUMMY VARIABLES. OPWCL3A.53
INTEGER !, INTENT(OUT) OPWCL3A.54
& IERR OPWCL3A.55
! ERROR FLAG OPWCL3A.56
INTEGER !, INTENT(IN) OPWCL3A.57
& N_PROFILE OPWCL3A.58
! NUMBER OF PROFILES OPWCL3A.59
& , N_LAYER OPWCL3A.60
! NUMBER OF LAYERS OPWCL3A.61
& , N_CLOUD_TOP OPWCL3A.62
! TOPMOST CLOUDY LAYER OPWCL3A.63
& , I_PARAMETRIZATION_DROP OPWCL3A.64
! TREATMENT OF DROPLETS OPWCL3A.65
& , N_CLOUD_PROFILE(NPD_LAYER) OPWCL3A.66
! NUMBER OF CLOUDY PROFILES OPWCL3A.67
& , I_CLOUD_PROFILE(NPD_PROFILE, NPD_LAYER) OPWCL3A.68
! PROFILES CONTAINING CLOUDS OPWCL3A.69
LOGICAL !, INTENT(IN) OPWCL3A.70
& L_LAYER OPWCL3A.71
! VARIABLES GIVEN IN LAYERS OPWCL3A.72
& , L_CLOUD_LAYER OPWCL3A.73
! CLOUD VARIABLES GIVEN IN LAYERS OPWCL3A.74
& , L_RESCALE OPWCL3A.75
! FLAG FOR DELTA-RESCALING OPWCL3A.76
REAL !, INTENT(IN) OPWCL3A.77
& CLOUD_PARAMETER(NPD_CLOUD_PARAMETER) OPWCL3A.78
! CLOUD PARAMETERS OPWCL3A.79
& , LIQ_WATER_MASS_FRAC(NPD_PROFILE, 0: NPD_LAYER) OPWCL3A.80
! LIQUID WATER CONTENT OPWCL3A.81
& , RADIUS_EFFECT(NPD_PROFILE, 0: NPD_LAYER) OPWCL3A.82
! EFFECTIVE RADIUS OPWCL3A.83
REAL !, INTENT(OUT) OPWCL3A.84
& K_EXT_SCAT_CLOUD(NPD_PROFILE, NPD_LAYER) OPWCL3A.85
! SCATTERING EXTINCTION OPWCL3A.86
& , K_EXT_TOT_CLOUD(NPD_PROFILE, NPD_LAYER) OPWCL3A.87
! TOTAL EXTINCTION OPWCL3A.88
& , ASYMMETRY_CLOUD(NPD_PROFILE, NPD_LAYER) OPWCL3A.89
! CLOUDY ASYMMETRIES OPWCL3A.90
& , FORWARD_SCATTER_CLOUD(NPD_PROFILE, NPD_LAYER) OPWCL3A.91
! CLOUDY FORWARD SCATTERING OPWCL3A.92
! OPWCL3A.93
! LOCAL VARIABLES. OPWCL3A.94
INTEGER OPWCL3A.95
& L OPWCL3A.96
! LOOP VARIABLE OPWCL3A.97
& , LL OPWCL3A.98
! LOOP VARIABLE OPWCL3A.99
& , I OPWCL3A.100
! LOOP VARIABLE OPWCL3A.101
& , j !loop variable GSS3F402.246
REAL OPWCL3A.102
& ASYMMETRY_PROCESS(NPD_PROFILE) OPWCL3A.103
! ASYMMETRY FACTOR FOR CURRENT PROC. OPWCL3A.104
& , RADIUS_AVE(3) GSS3F402.247
! AVERAGE EFFECTIVE RADIUS IN LAYER OPWCL3A.106
& , LIQ_MASS_FRAC_AVE OPWCL3A.107
! AVERAGE LIQUID WATER MASS FRACTION OPWCL3A.108
& , cp(3),cpp(3) GSS3F402.248
! workspace array GSS3F402.249
! HALF-PRECISION FUNCTIONS FOR THE UNIFIED MODEL. OPWCL3A.112
! OPWCL3A.121
! OPWCL3A.122
! OPWCL3A.123
! OPWCL3A.124
IF (I_PARAMETRIZATION_DROP.EQ.IP_SLINGO_SCHRECKER) THEN OPWCL3A.125
! OPWCL3A.126
! WE CALCULATE AVERAGE PROPERTIES FOR THE LAYER AND PUT THESE OPWCL3A.127
! INTO THE PARAMETRIZATION, RATHER THAN CALCULATING THE OPWCL3A.128
! PARAMETRIZATION AT EACH LEVEL: USUALLY THIS IS MORE ACCURATE. OPWCL3A.129
! IT ALSO FITS MORE NATURALLY WITH CASES WHERE DATA ARE GIVEN OPWCL3A.130
! IN LAYERS. OPWCL3A.131
! OPWCL3A.132
! OPWCL3A.133
DO I=N_CLOUD_TOP, N_LAYER OPWCL3A.134
DO LL=1, N_CLOUD_PROFILE(I) OPWCL3A.135
L=I_CLOUD_PROFILE(LL, I) OPWCL3A.136
LIQ_MASS_FRAC_AVE=LIQ_WATER_MASS_FRAC(L, I) OPWCL3A.137
RADIUS_AVE(1)=RADIUS_EFFECT(L, I) GSS3F402.250
K_EXT_TOT_CLOUD(L, I) OPWCL3A.139
& =LIQ_MASS_FRAC_AVE*(CLOUD_PARAMETER(1) OPWCL3A.140
& +CLOUD_PARAMETER(2)/RADIUS_AVE(1)) GSS3F402.251
K_EXT_SCAT_CLOUD(L, I)=K_EXT_TOT_CLOUD(L, I) OPWCL3A.142
& *(1.0E+00-CLOUD_PARAMETER(3) OPWCL3A.143
& -CLOUD_PARAMETER(4)*RADIUS_AVE(1)) GSS3F402.252
ASYMMETRY_PROCESS(L)= OPWCL3A.145
& CLOUD_PARAMETER(5)+CLOUD_PARAMETER(6) OPWCL3A.146
& *RADIUS_AVE(1) GSS3F402.253
ASYMMETRY_CLOUD(L, I)= OPWCL3A.148
& K_EXT_SCAT_CLOUD(L, I)*ASYMMETRY_PROCESS(L) OPWCL3A.149
ENDDO OPWCL3A.150
IF (L_RESCALE) THEN OPWCL3A.151
DO LL=1, N_CLOUD_PROFILE(I) OPWCL3A.152
L=I_CLOUD_PROFILE(LL, I) OPWCL3A.153
FORWARD_SCATTER_CLOUD(L, I) OPWCL3A.154
& =K_EXT_SCAT_CLOUD(L, I) OPWCL3A.155
& *ASYMMETRY_PROCESS(L)**2 OPWCL3A.156
ENDDO OPWCL3A.157
ENDIF OPWCL3A.158
ENDDO OPWCL3A.159
! OPWCL3A.160
ELSE IF (I_PARAMETRIZATION_DROP.EQ.IP_ACKERMAN_STEPHENS) THEN OPWCL3A.161
! OPWCL3A.162
! Set up CP array for use in rtor_v function GSS3F402.254
CP(1)=CLOUD_PARAMETER(3) GSS3F402.255
CP(2)=CLOUD_PARAMETER(6) GSS3F402.256
CP(3)=CLOUD_PARAMETER(9) GSS3F402.257
! GSS3F402.258
DO I=N_CLOUD_TOP, N_LAYER OPWCL3A.163
DO LL=1, N_CLOUD_PROFILE(I) OPWCL3A.164
L=I_CLOUD_PROFILE(LL, I) OPWCL3A.165
LIQ_MASS_FRAC_AVE=LIQ_WATER_MASS_FRAC(L, I) OPWCL3A.166
RADIUS_AVE(1)=RADIUS_EFFECT(L, I) GSS3F402.259
RADIUS_AVE(2)=RADIUS_EFFECT(L, I) GSS3F402.260
RADIUS_AVE(3)=RADIUS_EFFECT(L, I) GSS3F402.261
*IF DEF,VECTLIB PXVECTLB.112
call rtor_v(3,radius_ave,cp,cpp) GSS3F402.263
*ELSE GSS3F402.264
do j=1,3 GSS3F402.265
cpp(j)=radius_ave(j)**cp(j) GSS3F402.266
end do GSS3F402.267
*ENDIF GSS3F402.268
K_EXT_TOT_CLOUD(L, I)=LIQ_MASS_FRAC_AVE OPWCL3A.168
& *( CLOUD_PARAMETER(1)+CLOUD_PARAMETER(2) GSS3F402.269
& * CPP(1) ) GSS3F402.270
K_EXT_SCAT_CLOUD(L, I)=K_EXT_TOT_CLOUD(L, I) OPWCL3A.171
& *(1.0E+00-CLOUD_PARAMETER(4)-CLOUD_PARAMETER(5) GSS3F402.271
& * CPP(2) ) GSS3F402.272
ASYMMETRY_PROCESS(L)= OPWCL3A.175
& CLOUD_PARAMETER(7)+CLOUD_PARAMETER(8) OPWCL3A.176
& * CPP(3) GSS3F402.273
ASYMMETRY_CLOUD(L, I)= OPWCL3A.178
& K_EXT_SCAT_CLOUD(L, I)*ASYMMETRY_PROCESS(L) OPWCL3A.179
ENDDO OPWCL3A.180
IF (L_RESCALE) THEN OPWCL3A.181
DO LL=1, N_CLOUD_PROFILE(I) OPWCL3A.182
L=I_CLOUD_PROFILE(LL, I) OPWCL3A.183
FORWARD_SCATTER_CLOUD(L, I) OPWCL3A.184
& =K_EXT_SCAT_CLOUD(L, I) OPWCL3A.185
& *ASYMMETRY_PROCESS(L)**2 OPWCL3A.186
ENDDO OPWCL3A.187
ENDIF OPWCL3A.188
ENDDO OPWCL3A.189
! ADB1F405.404
ELSE IF (I_PARAMETRIZATION_DROP.EQ.IP_DROP_PADE_2) THEN ADB1F405.405
! ADB1F405.406
DO I=N_CLOUD_TOP, N_LAYER ADB1F405.407
DO LL=1, N_CLOUD_PROFILE(I) ADB1F405.408
L=I_CLOUD_PROFILE(LL, I) ADB1F405.409
LIQ_MASS_FRAC_AVE=LIQ_WATER_MASS_FRAC(L, I) ADB1F405.410
RADIUS_AVE(1)=RADIUS_EFFECT(L, I) ADB1F405.411
K_EXT_TOT_CLOUD(L, I)=LIQ_MASS_FRAC_AVE ADB1F405.412
& *(CLOUD_PARAMETER(1)+RADIUS_AVE(1) ADB1F405.413
& *(CLOUD_PARAMETER(2)+RADIUS_AVE(1) ADB1F405.414
& *CLOUD_PARAMETER(3))) ADB1F405.415
& /(1.0E+00+RADIUS_AVE(1) ADB1F405.416
& *(CLOUD_PARAMETER(4)+RADIUS_AVE(1) ADB1F405.417
& *(CLOUD_PARAMETER(5)+RADIUS_AVE(1) ADB1F405.418
& *CLOUD_PARAMETER(6)))) ADB1F405.419
K_EXT_SCAT_CLOUD(L, I)=K_EXT_TOT_CLOUD(L, I)*(1.0E+00 ADB1F405.420
& -(CLOUD_PARAMETER(7)+RADIUS_AVE(1) ADB1F405.421
& *(CLOUD_PARAMETER(8)+RADIUS_AVE(1) ADB1F405.422
& *CLOUD_PARAMETER(9))) ADB1F405.423
& /(1.0E+00+RADIUS_AVE(1) ADB1F405.424
& *(CLOUD_PARAMETER(10)+RADIUS_AVE(1) ADB1F405.425
& *CLOUD_PARAMETER(11)))) ADB1F405.426
ASYMMETRY_PROCESS(L) ADB1F405.427
& =(CLOUD_PARAMETER(12)+RADIUS_AVE(1) ADB1F405.428
& *(CLOUD_PARAMETER(13)+RADIUS_AVE(1) ADB1F405.429
& *CLOUD_PARAMETER(14))) ADB1F405.430
& /(1.0E+00+RADIUS_AVE(1) ADB1F405.431
& *(CLOUD_PARAMETER(15)+RADIUS_AVE(1) ADB1F405.432
& *CLOUD_PARAMETER(16))) ADB1F405.433
ASYMMETRY_CLOUD(L, I)= ADB1F405.434
& K_EXT_SCAT_CLOUD(L, I)*ASYMMETRY_PROCESS(L) ADB1F405.435
ENDDO ADB1F405.436
IF (L_RESCALE) THEN ADB1F405.437
DO LL=1, N_CLOUD_PROFILE(I) ADB1F405.438
L=I_CLOUD_PROFILE(LL, I) ADB1F405.439
FORWARD_SCATTER_CLOUD(L, I) ADB1F405.440
& =K_EXT_SCAT_CLOUD(L, I) ADB1F405.441
& *ASYMMETRY_PROCESS(L)**2 ADB1F405.442
ENDDO ADB1F405.443
ENDIF ADB1F405.444
ENDDO ADB1F405.445
! OPWCL3A.190
ELSE OPWCL3A.191
WRITE(IU_ERR, '(/A)') '*** ERROR: AN INVALID PARAMETRIZATION ' OPWCL3A.192
& //'OF CLOUD DROPLETS HAS BEEN USED.' OPWCL3A.193
IERR=I_ERR_FATAL OPWCL3A.194
RETURN OPWCL3A.195
ENDIF OPWCL3A.196
! OPWCL3A.197
! OPWCL3A.198
RETURN OPWCL3A.199
END OPWCL3A.200
*ENDIF DEF,A01_3A,OR,DEF,A02_3A OPWCL3A.201
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.60