SUBROUTINE CNV_CLD_CHK(P_FIELD,N_TYPES,NFTOUT,FIXHD, 1,9CNVCCHK1.23
& LEN1_LOOKUP,LEN2_LOOKUP,LOOKUP, CNVCCHK1.24
*CALL ARGPPX 
CNVCCHK1.25
& Q_LEVELS,PP_POS,PP_ITEMC) CNVCCHK1.26
IMPLICIT NONE CNVCCHK1.27
! CNVCCHK1.28
! Description: CNVCCHK1.29
! Method: CNVCCHK1.30
! CNVCCHK1.31
! Current Code Owner: D.M. Goddard CNVCCHK1.32
! CNVCCHK1.33
! History: CNVCCHK1.34
! Version Date Comment CNVCCHK1.35
! ------- ---- ------- CNVCCHK1.36
! 4.4 07/10/97 Original code. D.M. Goddard CNVCCHK1.37
! CNVCCHK1.38
! Code Description: CNVCCHK1.39
! Language: FORTRAN 77 + common extensions. CNVCCHK1.40
! This code is written to UMDP3 v6 programming standards. CNVCCHK1.41
! CNVCCHK1.42
! System component covered: <appropriate code> CNVCCHK1.43
! System Task: <appropriate code> CNVCCHK1.44
! CNVCCHK1.45
! Declarations: CNVCCHK1.46
! These are of the form:- CNVCCHK1.47
! INTEGER ExampleVariable !Description of variable CNVCCHK1.48
! CNVCCHK1.49
! Global variables (*CALLed COMDECKs etc...): CNVCCHK1.50
*CALL CSUBMODL CNVCCHK1.51
*CALL CPPXREF CNVCCHK1.52
*CALL PPXLOOK CNVCCHK1.53
! Subroutine arguments CNVCCHK1.54
! Scalar arguments with intent(in): CNVCCHK1.55
INTEGER P_FIELD !Number of points in field CNVCCHK1.56
INTEGER Q_LEVELS !Number of wet levels CNVCCHK1.57
INTEGER N_TYPES !No of different field types CNVCCHK1.58
INTEGER LEN1_LOOKUP !1st dim of lookup table CNVCCHK1.59
INTEGER LEN2_LOOKUP !2nd dim of lookup table CNVCCHK1.60
INTEGER NFTOUT !Output unit number CNVCCHK1.61
! Array arguments with intent(in): CNVCCHK1.62
INTEGER PP_ITEMC(LEN2_LOOKUP) CNVCCHK1.63
INTEGER PP_POS(LEN2_LOOKUP) CNVCCHK1.64
INTEGER FIXHD(256) CNVCCHK1.65
REAL LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) CNVCCHK1.66
! !Lookup table CNVCCHK1.67
! Array arguments with intent(InOut): CNVCCHK1.68
! Local scalars: CNVCCHK1.69
INTEGER I !Do loop index CNVCCHK1.70
INTEGER ICODE !Error code from I/O routines CNVCCHK1.71
INTEGER POS !Pointer used to address CNVCCHK1.72
LOGICAL LFLAGB !=T if convective cloud base CNVCCHK1.73
! is changed by this routine CNVCCHK1.74
LOGICAL LFLAGT !=T if convective cloud top CNVCCHK1.75
! is changed by this routine CNVCCHK1.76
CHARACTER*256 CNVCCHK1.77
& CMESSAGE !Error message from I/O CNVCCHK1.78
! Local dynamic arrays: CNVCCHK1.79
INTEGER BASE(P_FIELD) !Convective cloud base CNVCCHK1.80
INTEGER TOP(P_FIELD) !Convective cloud top CNVCCHK1.81
!- End of header CNVCCHK1.82
!-------------------------------------------------------------------- CNVCCHK1.83
! 1: Read in convective cloud base CNVCCHK1.84
CALL LOCATE (14,PP_ITEMC,N_TYPES,POS) CNVCCHK1.85
IF (POS.EQ.0) THEN CNVCCHK1.86
WRITE(6,*) 'Convective cloud base not found in output dump' CNVCCHK1.87
CALL ABORT CNVCCHK1.88
ELSE CNVCCHK1.89
CALL READFLDS (NFTOUT,1,PP_POS(POS),LOOKUP, CNVCCHK1.90
& LEN1_LOOKUP,BASE,P_FIELD,FIXHD, CNVCCHK1.91
*CALL ARGPPX CNVCCHK1.92
& ICODE,CMESSAGE) CNVCCHK1.93
END IF CNVCCHK1.94
CNVCCHK1.95
! 2: Read in convective cloud top CNVCCHK1.96
CALL LOCATE (15,PP_ITEMC,N_TYPES,POS) CNVCCHK1.97
IF (POS.EQ.0) THEN CNVCCHK1.98
WRITE(6,*) 'Convective cloud top not found in output dump' CNVCCHK1.99
CALL ABORT CNVCCHK1.100
ELSE CNVCCHK1.101
CALL READFLDS (NFTOUT,1,PP_POS(POS),LOOKUP, CNVCCHK1.102
& LEN1_LOOKUP,TOP,P_FIELD,FIXHD, CNVCCHK1.103
*CALL ARGPPX CNVCCHK1.104
& ICODE,CMESSAGE) CNVCCHK1.105
END IF CNVCCHK1.106
CNVCCHK1.107
! 3: Compare all points CNVCCHK1.108
LFLAGB=.FALSE. CNVCCHK1.109
LFLAGT=.FALSE. CNVCCHK1.110
DO I=1,P_FIELD CNVCCHK1.111
IF(BASE(I).EQ.TOP(I).AND.TOP(I).NE.0)THEN CNVCCHK1.112
IF(TOP(I).NE.Q_LEVELS)THEN CNVCCHK1.113
! Convective cloud base and top the same. CNVCCHK1.114
! Increment convective cloud top by one. CNVCCHK1.115
LFLAGT=.TRUE. CNVCCHK1.116
TOP(I)=TOP(I)+1 CNVCCHK1.117
ELSE CNVCCHK1.118
! Convective cloud base and top the same. CNVCCHK1.119
! Decrement convective cloud base by one. CNVCCHK1.120
LFLAGB=.TRUE. CNVCCHK1.121
BASE(I)=BASE(I)-1 CNVCCHK1.122
END IF CNVCCHK1.123
END IF CNVCCHK1.124
END DO CNVCCHK1.125
CNVCCHK1.126
! 4: Write convective cloud top if changed. CNVCCHK1.127
IF(LFLAGT)THEN CNVCCHK1.128
CALL WRITFLDS (NFTOUT,1,PP_POS(POS),LOOKUP, CNVCCHK1.129
& LEN1_LOOKUP,TOP,P_FIELD,FIXHD, CNVCCHK1.130
*CALL ARGPPX CNVCCHK1.131
& ICODE,CMESSAGE) CNVCCHK1.132
END IF CNVCCHK1.133
CNVCCHK1.134
! 5: Write convective cloud base if changed. CNVCCHK1.135
IF(LFLAGB)THEN CNVCCHK1.136
CALL LOCATE (14,PP_ITEMC,N_TYPES,POS) CNVCCHK1.137
CALL WRITFLDS (NFTOUT,1,PP_POS(POS),LOOKUP, CNVCCHK1.138
& LEN1_LOOKUP,BASE,P_FIELD,FIXHD, CNVCCHK1.139
*CALL ARGPPX CNVCCHK1.140
& ICODE,CMESSAGE) CNVCCHK1.141
END IF CNVCCHK1.142
CNVCCHK1.143
RETURN CNVCCHK1.144
END CNVCCHK1.145
*ENDIF CNVCCHK1.146