*IF DEF,RECON DV_3DCCA.2
C *****************************COPYRIGHT****************************** DV_3DCCA.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. DV_3DCCA.4
C DV_3DCCA.5
C Use, duplication or disclosure of this code is subject to the DV_3DCCA.6
C restrictions as set forth in the contract. DV_3DCCA.7
C DV_3DCCA.8
C Meteorological Office DV_3DCCA.9
C London Road DV_3DCCA.10
C BRACKNELL DV_3DCCA.11
C Berkshire UK DV_3DCCA.12
C RG12 2SZ DV_3DCCA.13
C DV_3DCCA.14
C If no contract has been raised with this copy of the code, the use, DV_3DCCA.15
C duplication or disclosure of it is strictly prohibited. Permission DV_3DCCA.16
C to do so must first be obtained in writing from the Head of Numerical DV_3DCCA.17
C Modelling at the above address. DV_3DCCA.18
C ******************************COPYRIGHT****************************** DV_3DCCA.19
! Subroutine DERV_3D_CCA: Derives 3D conv cloud amount (CCA) from 2D CCA DV_3DCCA.20
! DV_3DCCA.21
! Subroutine Interface: DV_3DCCA.22
SUBROUTINE DERV_3D_CCA(CCA_2D,NFTOUT,PP_POS_OUT,LOOKUP_OUT 1,17DV_3DCCA.23
& ,LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT,NPNTS DV_3DCCA.24
& ,NWET,NBL,NLEV,ANVIL_FACTOR,TOWER_FACTOR DV_3DCCA.25
& ,L_CLOUD_DEEP AJX3F405.217
& ,PP_ITEMC_OUT,N_TYPES_OUT,FIXHD_OUT, DV_3DCCA.26
*CALL ARGPPX 
DV_3DCCA.27
& AKH,BKH,P_HALF_TMP,PSTAR) DV_3DCCA.28
! DV_3DCCA.29
IMPLICIT NONE DV_3DCCA.30
! DV_3DCCA.31
! Description: Uses the 2D convective cloud amount from the input DV_3DCCA.32
! dump (passed in), reads in cloud base and top DV_3DCCA.33
! from the input dump and then calls CALC_3D_CCA to DV_3DCCA.34
! initialise a 3D convective cloud amount. DV_3DCCA.35
! DV_3DCCA.36
! Method: LOCATE and READFLDS are called to extract convective DV_3DCCA.37
! cloud base and top from the input dump. This information DV_3DCCA.38
! and the 2D cloud amount is passed to CALC_3D_CCA to obtain DV_3DCCA.39
! a 3D convective cloud amount. DV_3DCCA.40
! DV_3DCCA.41
! Current Code Owner: Julie M. Gregory DV_3DCCA.42
! DV_3DCCA.43
! History: DV_3DCCA.44
! Version Date Comment DV_3DCCA.45
! ------- ---- ------- DV_3DCCA.46
! 4.4 23/09/97 Original code. J.Gregory DV_3DCCA.47
! DV_3DCCA.48
! Code Description: DV_3DCCA.49
! Language: FORTRAN 77 + common extensions. DV_3DCCA.50
! This code is written to UMDP3 v6 programming standards. DV_3DCCA.51
! DV_3DCCA.52
! System component covered: <appropriate code> DV_3DCCA.53
! System Task: <appropriate code> DV_3DCCA.54
! DV_3DCCA.55
! Global variables (*CALLed COMDECKs etc...): DV_3DCCA.56
*CALL C_0_DG_C DV_3DCCA.57
*CALL C_R_CP DV_3DCCA.58
*CALL CSUBMODL DV_3DCCA.59
*CALL CPPXREF DV_3DCCA.60
*CALL PPXLOOK DV_3DCCA.61
! Subroutine arguments DV_3DCCA.62
!------------------------------------------------------------------ DV_3DCCA.63
! Scalar arguments with intent(in): DV_3DCCA.64
!------------------------------------------------------------------ DV_3DCCA.65
INTEGER NPNTS ! IN Number of points DV_3DCCA.66
& ,NWET ! IN Number of wet levels DV_3DCCA.67
& ,NBL ! IN Number of Boundary layer levels DV_3DCCA.68
& ,NLEV ! IN Number of levels DV_3DCCA.69
& ,NFTOUT ! IN argument for READFLDS DV_3DCCA.70
& ,LEN1_LOOKUP_OUT ! IN 1st dim of lookup header (output) DV_3DCCA.71
& ,LEN2_LOOKUP_OUT ! IN 2nd dim of lookup header (output) DV_3DCCA.72
& ,LOOKUP_OUT(LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT) DV_3DCCA.73
& ,N_TYPES_OUT ! IN No of different field types DV_3DCCA.74
! DV_3DCCA.75
REAL ANVIL_FACTOR ! IN Needed in calculation of vertical DV_3DCCA.76
& ,TOWER_FACTOR ! IN cloud amount distribution DV_3DCCA.77
! AJX3F405.218
LOGICAL L_CLOUD_DEEP ! AJX3F405.219
!------------------------------------------------------------------ DV_3DCCA.78
! Array arguments with intent(in): DV_3DCCA.79
!------------------------------------------------------------------ DV_3DCCA.80
INTEGER PP_ITEMC_OUT(LEN2_LOOKUP_OUT) ! IN Item code DV_3DCCA.81
& ,FIXHD_OUT(256) ! IN Fixed length header DV_3DCCA.82
& ,PP_POS_OUT(LEN2_LOOKUP_OUT) ! IN position in output file DV_3DCCA.83
! DV_3DCCA.84
REAL PSTAR(NPNTS) ! IN Surface pressure DV_3DCCA.85
& ,AKH(NLEV+1) ! IN Hybrid co-ord coeffs to define DV_3DCCA.86
& ,BKH(NLEV+1) ! pressure at level k-1/2 DV_3DCCA.87
& ,CCA_2D(NPNTS) ! IN 2D convective cloud amount DV_3DCCA.88
& ,P_HALF_TMP(NPNTS,NLEV+1) !Pressure of output half levels DV_3DCCA.89
!------------------------------------------------------------------ DV_3DCCA.90
! Local array arguments: DV_3DCCA.91
!------------------------------------------------------------------ DV_3DCCA.92
REAL WORK(NPNTS,NLEV) ! Space used for convective cloud DV_3DCCA.93
! ! amount then theta on model levels DV_3DCCA.94
REAL TT(NPNTS) ! Temperature of current level (K) DV_3DCCA.95
! ! DV_3DCCA.96
REAL TTKM1(NPNTS) ! Temperature of level k minus 1 (K) DV_3DCCA.97
! ! DV_3DCCA.98
INTEGER FREEZE_LEV(NPNTS) ! Freezing level DV_3DCCA.99
! DV_3DCCA.100
INTEGER CCB(NPNTS) ! Convective cloud base level DV_3DCCA.101
! DV_3DCCA.102
INTEGER CCT(NPNTS) ! Convective cloud top level DV_3DCCA.103
! DV_3DCCA.104
INTEGER ICODE ! OUT Return code; successful=0 DV_3DCCA.105
! ! error > 0 DV_3DCCA.106
& ,POS ! position in output file DV_3DCCA.107
! DV_3DCCA.108
!------------------------------------------------------------------ DV_3DCCA.109
! Local scalar arguments: DV_3DCCA.110
!------------------------------------------------------------------ DV_3DCCA.111
CHARACTER*256 DV_3DCCA.112
* CMESSAGE ! Error message if ICODE > 0 DV_3DCCA.113
! DV_3DCCA.114
INTEGER I,K ! Loop counters DV_3DCCA.115
! Function & Subroutine calls: DV_3DCCA.116
External CALC_3D_CCA,READFLDS,WRITFLDS,LOCATE AJX4F405.3
! DV_3DCCA.118
!- End of header DV_3DCCA.119
! Get CCB field from output dump DV_3DCCA.120
CALL LOCATE (14,PP_ITEMC_OUT,N_TYPES_OUT,POS) DV_3DCCA.121
IF (POS.EQ.0) THEN DV_3DCCA.122
CMESSAGE = DV_3DCCA.123
& 'CONTROL : Problem with initialising 3D CCA' DV_3DCCA.124
WRITE (6,*) ' CCB not found in output dump.' DV_3DCCA.125
WRITE (6,*) ' 3D CCA cannot be initialised.' DV_3DCCA.126
CALL ABORT DV_3DCCA.127
ELSE DV_3DCCA.128
CALL READFLDS (NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT, DV_3DCCA.129
& LEN1_LOOKUP_OUT,CCB,NPNTS,FIXHD_OUT, DV_3DCCA.130
*CALL ARGPPX DV_3DCCA.131
& ICODE,CMESSAGE) DV_3DCCA.132
IF (ICODE.GT.0) THEN DV_3DCCA.133
WRITE (6,*) ' Problem with reading CCB field.' DV_3DCCA.134
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) DV_3DCCA.135
ENDIF DV_3DCCA.136
ENDIF DV_3DCCA.137
! DV_3DCCA.138
! Get CCT field from output dump DV_3DCCA.139
CALL LOCATE (15,PP_ITEMC_OUT,N_TYPES_OUT,POS) DV_3DCCA.140
IF (POS.EQ.0) THEN DV_3DCCA.141
CMESSAGE = DV_3DCCA.142
& 'CONTROL : Problem with initialising 3D CCA' DV_3DCCA.143
WRITE (6,*) ' CCT not found in output dump.' DV_3DCCA.144
WRITE (6,*) ' 3D CCA cannot be initialised.' DV_3DCCA.145
CALL ABORT DV_3DCCA.146
ELSE DV_3DCCA.147
CALL READFLDS (NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT, DV_3DCCA.148
& LEN1_LOOKUP_OUT,CCT,NPNTS,FIXHD_OUT, DV_3DCCA.149
*CALL ARGPPX DV_3DCCA.150
& ICODE,CMESSAGE) DV_3DCCA.151
IF (ICODE.GT.0) THEN DV_3DCCA.152
WRITE (6,*) ' Problem with reading CCT field.' DV_3DCCA.153
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) DV_3DCCA.154
ENDIF DV_3DCCA.155
ENDIF DV_3DCCA.156
! DV_3DCCA.157
! Get thetal field from output dump DV_3DCCA.158
CALL LOCATE (5,PP_ITEMC_OUT,N_TYPES_OUT,POS) DV_3DCCA.159
IF (POS.EQ.0) THEN DV_3DCCA.160
CMESSAGE = DV_3DCCA.161
& 'CONTROL : Problem with initialising 3D CCA' DV_3DCCA.162
WRITE (6,*) ' thetal not found in output dump.' DV_3DCCA.163
WRITE (6,*) ' 3D CCA cannot be initialised.' DV_3DCCA.164
CALL ABORT DV_3DCCA.165
ELSE DV_3DCCA.166
CALL READFLDS (NFTOUT,NLEV,PP_POS_OUT(POS),LOOKUP_OUT, DV_3DCCA.167
& LEN1_LOOKUP_OUT,WORK,NPNTS,FIXHD_OUT, DV_3DCCA.168
*CALL ARGPPX DV_3DCCA.169
& ICODE,CMESSAGE) DV_3DCCA.170
! Work array now contains thetal DV_3DCCA.171
IF (ICODE.GT.0) THEN DV_3DCCA.172
WRITE (6,*) ' Problem with reading thetal field.' DV_3DCCA.173
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) DV_3DCCA.174
ENDIF DV_3DCCA.175
ENDIF DV_3DCCA.176
! DV_3DCCA.177
! Calculate temperature from thetal, pressure and pstar and work out DV_3DCCA.178
! freezing level DV_3DCCA.179
! DV_3DCCA.180
DO K=1,NLEV DV_3DCCA.181
DO I = 1,NPNTS DV_3DCCA.182
TTKM1(I)=TT(I) DV_3DCCA.183
TT(I) = WORK(I,K)*((P_HALF_TMP(I,K)/PSTAR(I))**KAPPA) DV_3DCCA.184
IF (TT(I).LT.TM) THEN DV_3DCCA.185
IF (K.EQ.1) THEN DV_3DCCA.186
FREEZE_LEV(I)=K DV_3DCCA.187
ELSEIF(TTKM1(I).GT.TM) THEN DV_3DCCA.188
FREEZE_LEV(I)=K DV_3DCCA.189
ENDIF DV_3DCCA.190
ENDIF DV_3DCCA.191
ENDDO DV_3DCCA.192
ENDDO DV_3DCCA.193
! DV_3DCCA.194
! Initialise 3D CCA by calling CALC_3D_CCA DV_3DCCA.195
! Overwrite space in work array occupied by theta (no longer required) DV_3DCCA.196
! and use for 3D convective cloud amount DV_3DCCA.197
! DV_3DCCA.198
CALL CALC_3D_CCA(NPNTS,NPNTS,NWET,NBL,ANVIL_FACTOR DV_3DCCA.199
& ,TOWER_FACTOR,AKH,BKH DV_3DCCA.200
& ,CCB,CCT,FREEZE_LEV,PSTAR DV_3DCCA.201
& ,CCA_2D,WORK,L_CLOUD_DEEP) AJX3F405.220
! Work array contains 3D CCA DV_3DCCA.203
CALL LOCATE (211,PP_ITEMC_OUT,N_TYPES_OUT,POS) DV_3DCCA.204
IF(POS.EQ.0)THEN DV_3DCCA.205
WRITE(6,'('' *ERROR* 3D CCA not in output file'')') DV_3DCCA.206
CALL ABORT DV_3DCCA.207
ENDIF DV_3DCCA.208
CALL WRITFLDS (NFTOUT,NWET,PP_POS_OUT(POS), DV_3DCCA.209
& LOOKUP_OUT,LEN1_LOOKUP_OUT, DV_3DCCA.210
& WORK,NPNTS,FIXHD_OUT, DV_3DCCA.211
*CALL ARGPPX DV_3DCCA.212
& ICODE,CMESSAGE) DV_3DCCA.213
IF (ICODE.GT.0) THEN DV_3DCCA.214
WRITE (6,*) ' Problem with writing 3D CCA' DV_3DCCA.215
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) DV_3DCCA.216
ENDIF DV_3DCCA.217
WRITE (6,*) ' 3D CCA (Stash Code 211) has ', DV_3DCCA.218
&'been initialised using subroutine CALC_3D_CCA' DV_3DCCA.219
! DV_3DCCA.220
RETURN DV_3DCCA.221
END DV_3DCCA.222
*ENDIF DV_3DCCA.223