*IF DEF,CONTROL,AND,DEF,ATMOS SETLSCL1.2
C ******************************COPYRIGHT****************************** GTS2F400.8623
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.8624
C GTS2F400.8625
C Use, duplication or disclosure of this code is subject to the GTS2F400.8626
C restrictions as set forth in the contract. GTS2F400.8627
C GTS2F400.8628
C Meteorological Office GTS2F400.8629
C London Road GTS2F400.8630
C BRACKNELL GTS2F400.8631
C Berkshire UK GTS2F400.8632
C RG12 2SZ GTS2F400.8633
C GTS2F400.8634
C If no contract has been raised with this copy of the code, the use, GTS2F400.8635
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.8636
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.8637
C Modelling at the above address. GTS2F400.8638
C ******************************COPYRIGHT****************************** GTS2F400.8639
C GTS2F400.8640
CLL SUBROUTINE SETLSCLD ---------------------------------------------- SETLSCL1.3
CLL SETLSCL1.4
CLL PURPOSE: CALLS LS_CLD TO CONVERT LIQUID WATER TEMPERATURE SETLSCL1.5
CLL AND TOTAL WATER INTO TEMPERATURE, MOISTURE, CLOUD WATER SETLSCL1.6
CLL AND CLOUD ICE. SETLSCL1.7
CLL THIS ROUTINE IS A STRIPPED DOWN VERSION OF CLD_CTL WITH SETLSCL1.8
CLL ALL OUTPUT SUPPRESSED. SETLSCL1.9
CLL SETLSCL1.10
CLL LEVEL 2 CONTROL ROUTINE SETLSCL1.11
CLL VERSION FOR CRAY YMP SETLSCL1.12
CLL SETLSCL1.13
CLL TJ CW <- PROGRAMMER OF SOME OR ALL OF PREVIOUS CODE OR CHANGES SETLSCL1.14
CLL SETLSCL1.15
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: SETLSCL1.16
CLL VERSION DATE SETLSCL1.17
CLL 3.1 8/02/93 : added comdeck CHSUNITS to define NUNITS for RS030293.224
CLL comdeck CCONTROL. RS030293.225
!LL 3.2 27/03/93 Dynamic allocation of main data arrays. R. Rawlins AYY2F400.53
!LL 3.3 24/09/93 added P_FIELDDA and Q_LEVELSDA to argument list AYY2F400.54
!LL for portable dynamic arrays. AYY2F400.55
!LL Author : Paul Burton AYY2F400.56
!LL 4.0 22/11/94 Extra arguments Qc, bs added to GLUE_CLD argument AYY2F400.57
!LL list for output to LS_PPN routine. A.C. Bushell. AYY2F400.58
CLL 3.5 19/05/95 : Sub_model changes - removal of run time ADR1F305.207
CLL constants from dump header. D. Robinson ADR1F305.208
!LL 4.5 13/05/98 Altered call to GLUE_CLD, and ensure bit ASK1F405.102
!LL comparison in new microphysics scheme. S. Cusack ASK1F405.103
!LL 4.5 27/04/98 Add Fujitsu vectorization directive. GRB0F405.53
!LL RBarnes@ecmwf.int GRB0F405.54
CLL SETLSCL1.18
CLL PROGRAMMING STANDARD : UNIFIED MODEL DOCUMENTATION PAPER NO 3 SETLSCL1.19
CLL SETLSCL1.20
CLL SYSTEM COMPONENTS COVERED : P29 SETLSCL1.21
CLL SETLSCL1.22
CLL SYSTEM TASK : P0 SETLSCL1.23
CLL SETLSCL1.24
CLL EXTERNAL DOCUMENTATION: UMDP P0, VERSION 12 DATED (12/90) SETLSCL1.25
CLLEND ----------------------------------------------------------------- SETLSCL1.26
C*L ARGUMENTS SETLSCL1.27
SETLSCL1.28
SUBROUTINE SETLSCLD( 1,6@DYALLOC.3240
*CALL ARGSIZE 
@DYALLOC.3241
*CALL ARGD1 @DYALLOC.3242
*CALL ARGDUMA @DYALLOC.3243
*CALL ARGPTRA @DYALLOC.3244
*CALL ARGCONA @DYALLOC.3245
& P_FIELDDA, Q_LEVELSDA, NF171193.51
& ICODE,CMESSAGE) @DYALLOC.3246
SETLSCL1.30
IMPLICIT NONE SETLSCL1.31
SETLSCL1.32
C @DYALLOC.3247
*CALL CMAXSIZE @DYALLOC.3248
*CALL TYPSIZE @DYALLOC.3249
*CALL TYPD1 @DYALLOC.3250
*CALL TYPDUMA @DYALLOC.3251
*CALL TYPPTRA @DYALLOC.3252
*CALL TYPCONA @DYALLOC.3253
*CALL TYPFLDPT ASK1F405.104
C @DYALLOC.3254
INTEGER ICODE ! OUT: Error return code @DYALLOC.3255
CHARACTER*256 CMESSAGE ! OUT: Error return message @DYALLOC.3256
C @DYALLOC.3257
INTEGER P_FIELDDA, ! IN : copy of P_FIELD NF171193.52
& Q_LEVELSDA ! IN : copy of Q_LEVELS NF171193.53
REAL AYY2F400.59
& CLOUD_FRACTION(P_FIELDDA,Q_LEVELSDA) ! LOCAL Cloud fraction AYY2F400.60
& ,LS_GRID_QC(P_FIELDDA,Q_LEVELSDA) ! LOCAL Qc from LS_CLD AYY2F400.61
& ,LS_BS(P_FIELDDA,Q_LEVELSDA) ! LOCAL bs from LS_CLD AYY2F400.62
C @DYALLOC.3259
SETLSCL1.42
C --------------------- INCLUDE COMDECKS -------------------------- SETLSCL1.43
*CALL PARVARS ASK1F405.105
*CALL CSUBMODL GDR3F305.181
*CALL CHSUNITS RS030293.226
*CALL CCONTROL SETLSCL1.44
*CALL CRUNTIMC ADR1F305.209
*CALL C_R_CP SETLSCL1.48
SETLSCL1.49
C*L SUBROUTINES CALLED SETLSCL1.50
EXTERNAL GLUE_CLD,TIMER AYY2F400.63
& ,RHCRIT_CALC ASK1F405.106
SETLSCL1.52
C local variables SETLSCL1.53
INTEGER LEVEL,I SETLSCL1.54
& ,FIRST_POINT ASK1F405.107
& ,LAST_POINT ASK1F405.108
& ,POINTS ASK1F405.109
& ,JS ASK1F405.110
SETLSCL1.55
REAL SETLSCL1.56
& PU,PL SETLSCL1.57
*CALL P_EXNERC SETLSCL1.58
*CALL SETFLDPT ASK1F405.111
SETLSCL1.59
CL INTERNAL STRUCTURE: SETLSCL1.60
CL SETLSCL1.61
CL -------------SECTION 9 CLOUD AMOUNT CALCULATIONS ------------------- SETLSCL1.62
SETLSCL1.63
CL Convert potential temperature to temperature SETLSCL1.64
SETLSCL1.65
DO LEVEL=1,Q_LEVELS SETLSCL1.66
! Fujitsu vectorization directive GRB0F405.55
!OCL NOVREC GRB0F405.56
DO I=1,P_FIELD SETLSCL1.67
PU=D1(JPSTAR+I-1)*BKH(LEVEL+1) + AKH(LEVEL+1) SETLSCL1.68
PL=D1(JPSTAR+I-1)*BKH(LEVEL) + AKH(LEVEL) SETLSCL1.69
D1(JTHETA(LEVEL)+I-1)=D1(JTHETA(LEVEL)+I-1)* SETLSCL1.70
& P_EXNER_C( D1(JP_EXNER(LEVEL+1)+I-1),D1(JP_EXNER(LEVEL)+I-1), SETLSCL1.71
& PU,PL,KAPPA ) SETLSCL1.72
ENDDO SETLSCL1.73
ENDDO SETLSCL1.74
SETLSCL1.75
!L 9.1 CALL GLUE_CLD TO CALCULATE CLOUD FRACTION AND AYY2F400.64
CL CLOUD WATER/ICE CONTENT SETLSCL1.77
SETLSCL1.78
IF(LTIMER) THEN SETLSCL1.79
CALL TIMER('LS_CLD ',3) SETLSCL1.80
END IF SETLSCL1.81
SETLSCL1.82
IF (L_RHCPT) THEN ASK1F405.112
! ASK1F405.113
! Set data field with care - do not wish to use first row of P_FIELD at ASK1F405.114
! N.Pole, nor last row at S.Pole ASK1F405.115
FIRST_POINT = FIRST_VALID_PT ASK1F405.116
LAST_POINT = LAST_P_VALID_PT ASK1F405.117
POINTS = LAST_POINT-FIRST_POINT+1 ASK1F405.118
JS = FIRST_POINT-1 ASK1F405.119
! ASK1F405.120
! A swapbounds must be performed on theta, because values in the halo ASK1F405.121
! regions do not equal the corresponding values in the adjacent PE's ASK1F405.122
! data region. RHcrit depends upon theta, so bit comparison can be ASK1F405.123
! lost unless swapbounds is called for theta. ASK1F405.124
*IF DEF,MPP ASK1F405.125
CALL SWAPBOUNDS(D1(JTHETA(1)),ROW_LENGTH,P_ROWS,EW_Halo,NS_Halo, ASK1F405.126
& Q_LEVELS) ASK1F405.127
*ENDIF ASK1F405.128
! ASK1F405.129
! Calculate critical relative humidity for all grid points ASK1F405.130
CALL RHCRIT_CALC( ASK1F405.131
& A_LEVDEPC(JAK),A_LEVDEPC(JBK),AKH,BKH,D1(JPSTAR+JS), ASK1F405.132
& D1(JRHC(1)+JS),Q_LEVELS,POINTS,P_FIELD, ASK1F405.133
& D1(JTHETA(1)+JS),D1(JQ(1)+JS),D1(JQCF(1)+JS), ASK1F405.134
& ROW_LENGTH,D1(JLAND+JS),D1(JICE_FRACTION+JS),BL_LEVELS) ASK1F405.135
! ASK1F405.136
*IF DEF,MPP ASK1F405.137
CALL SWAPBOUNDS(D1(JRHC(1)),ROW_LENGTH,P_ROWS,EW_Halo,NS_Halo, ASK1F405.138
& Q_LEVELS) ASK1F405.139
*ENDIF ASK1F405.140
! ASK1F405.141
ENDIF ASK1F405.142
CALL GLUE_CLD( AYY2F400.65
& A_LEVDEPC(JAK),A_LEVDEPC(JBK),D1(JPSTAR), SETLSCL1.84
& RHCRIT,Q_LEVELS,D1(JRHC(1)), ASK1F405.143
& P_FIELD,P_FIELD,D1(JTHETA(1)), SETLSCL1.86
& CLOUD_FRACTION,D1(JQ(1)),D1(JQCF(1)),D1(JQCL(1)), AYY2F400.66
& LS_GRID_QC,LS_BS,ICODE) AYY2F400.67
SETLSCL1.88
IF(LTIMER) THEN SETLSCL1.89
CALL TIMER('LS_CLD ',4) SETLSCL1.90
END IF SETLSCL1.91
SETLSCL1.92
IF(ICODE.GT.0) THEN SETLSCL1.93
CMESSAGE="CLD_CTL : ERROR IN LS_CLD" SETLSCL1.94
RETURN SETLSCL1.95
END IF SETLSCL1.96
SETLSCL1.97
CL Convert temperature to potential temperature SETLSCL1.98
SETLSCL1.99
DO LEVEL=1,Q_LEVELS SETLSCL1.100
! Fujitsu vectorization directive GRB0F405.57
!OCL NOVREC GRB0F405.58
DO I=1,P_FIELD SETLSCL1.101
PU=D1(JPSTAR+I-1)*BKH(LEVEL+1) + AKH(LEVEL+1) SETLSCL1.102
PL=D1(JPSTAR+I-1)*BKH(LEVEL) + AKH(LEVEL) SETLSCL1.103
D1(JTHETA(LEVEL)+I-1)=D1(JTHETA(LEVEL)+I-1)/ SETLSCL1.104
& P_EXNER_C( D1(JP_EXNER(LEVEL+1)+I-1),D1(JP_EXNER(LEVEL)+I-1), SETLSCL1.105
& PU,PL,KAPPA ) SETLSCL1.106
ENDDO SETLSCL1.107
ENDDO SETLSCL1.108
SETLSCL1.109
RETURN SETLSCL1.110
END SETLSCL1.111
*ENDIF SETLSCL1.112