SUBROUTINE SET_PPINDEX ( 1SETPPIN1.24
& JPSTAR,JU,JV,JTHETA,JQ,JQCF,JTRACER, SETPPIN1.25
& LEN_PPINDEX,PPINDEX, SETPPIN1.26
& LEN1_LOOKUP,LEN2_LOOKUP,LOOKUP, SETPPIN1.27
& L_LSPICE,ICODE,CMESSAGE) SETPPIN1.28
SETPPIN1.29
IMPLICIT NONE SETPPIN1.30
SETPPIN1.31
! Description : Initialise PPINDEX array and pointers. SETPPIN1.32
! SETPPIN1.33
! Method : This routine goes through the lookup table and sets up SETPPIN1.34
! PPINDEX and the pointers to the data in the dump. SETPPIN1.35
! SETPPIN1.36
! Current Code Owner : Dave Robinson, NWP SETPPIN1.37
! SETPPIN1.38
! History : SETPPIN1.39
! Version Date Comment SETPPIN1.40
! ------- ---- ------- SETPPIN1.41
! 4.4 10/10/97 Original Code SETPPIN1.42
! SETPPIN1.43
! Code Description : SETPPIN1.44
! Language : FORTRAN 77 + common extensions SETPPIN1.45
! This code is written to UMDP3 v6 programming standards. SETPPIN1.46
! SETPPIN1.47
! Declarations : SETPPIN1.48
! SETPPIN1.49
! Global Variables : SETPPIN1.50
SETPPIN1.51
! Subroutine arguments SETPPIN1.52
! Scalar arguments with intent(in) : SETPPIN1.53
SETPPIN1.54
Integer LEN_PPINDEX ! Dimension of PP_INDEX SETPPIN1.55
Integer LEN1_LOOKUP ! First dimension of Lookup table SETPPIN1.56
Integer LEN2_LOOKUP ! Second dimension of Lookup table SETPPIN1.57
SETPPIN1.58
Logical L_LSPICE ! T : Dumps contain QCF. SETPPIN1.59
SETPPIN1.60
! Array arguments with intent(in) : SETPPIN1.61
SETPPIN1.62
Integer LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) ! Lookup table SETPPIN1.63
SETPPIN1.64
! Scalar arguments with intent(inout) : SETPPIN1.65
SETPPIN1.66
! Array arguments with intent(inout) : SETPPIN1.67
SETPPIN1.68
! Scalar arguments with intent(out) : SETPPIN1.69
SETPPIN1.70
Integer JPSTAR ! Pointer to pstar SETPPIN1.71
Integer JU ! Pointer to u component SETPPIN1.72
Integer JV ! Pointer to v component SETPPIN1.73
Integer JTHETA ! Pointer to thetal SETPPIN1.74
Integer JQ ! Pointer to qt SETPPIN1.75
Integer JQCF ! Pointer to qcf SETPPIN1.76
Integer JTRACER ! Pointer to atm tracer 1 SETPPIN1.77
Integer ICODE ! Error code SETPPIN1.78
Character*80 CMESSAGE ! Error Message SETPPIN1.79
SETPPIN1.80
! Array arguments with intent(out) : SETPPIN1.81
SETPPIN1.82
Integer PPINDEX(LEN_PPINDEX) ! Position of fields in LOOKUP SETPPIN1.83
SETPPIN1.84
! Local parameters : SETPPIN1.85
SETPPIN1.86
! Local scalars : SETPPIN1.87
SETPPIN1.88
Integer I ! Loop index SETPPIN1.89
SETPPIN1.90
!- End of Header SETPPIN1.91
SETPPIN1.92
JPSTAR = -1 SETPPIN1.93
JU = -1 SETPPIN1.94
JV = -1 SETPPIN1.95
JTHETA = -1 SETPPIN1.96
JQ = -1 SETPPIN1.97
JQCF = -1 SETPPIN1.98
JTRACER = -1 SETPPIN1.99
SETPPIN1.100
DO I=1,LEN2_LOOKUP SETPPIN1.101
IF ((JPSTAR.EQ.-1).AND.(LOOKUP(42,I) .EQ. 1)) THEN SETPPIN1.102
SETPPIN1.103
JPSTAR=LOOKUP(40,I) SETPPIN1.104
PPINDEX(1) = I SETPPIN1.105
SETPPIN1.106
ELSEIF ((JU.EQ.-1).AND.(LOOKUP(42,I) .EQ. 2)) THEN SETPPIN1.107
SETPPIN1.108
JU=LOOKUP(40,I) SETPPIN1.109
PPINDEX(2) = I SETPPIN1.110
ELSEIF ((JV.EQ.-1).AND.(LOOKUP(42,I) .EQ. 3)) THEN SETPPIN1.111
SETPPIN1.112
JV=LOOKUP(40,I) SETPPIN1.113
PPINDEX(3) = I SETPPIN1.114
SETPPIN1.115
ELSEIF ((JTHETA.EQ.-1).AND.(LOOKUP(42,I) .EQ. 5)) THEN SETPPIN1.116
SETPPIN1.117
JTHETA=LOOKUP(40,I) SETPPIN1.118
PPINDEX(5) = I SETPPIN1.119
SETPPIN1.120
ELSEIF ((JQ.EQ.-1).AND.(LOOKUP(42,I) .EQ. 11)) THEN SETPPIN1.121
SETPPIN1.122
JQ=LOOKUP(40,I) SETPPIN1.123
PPINDEX(11) = I SETPPIN1.124
SETPPIN1.125
ELSEIF ((JQCF.EQ.-1).AND.(LOOKUP(42,I) .EQ. 12)) THEN SETPPIN1.126
SETPPIN1.127
JQCF=LOOKUP(40,I) SETPPIN1.128
PPINDEX(12) = I SETPPIN1.129
SETPPIN1.130
ELSEIF ((LOOKUP(42,I) .GE. 61).AND.(LOOKUP(42,I) .LE. 89)) THEN SETPPIN1.131
SETPPIN1.132
IF (JTRACER.EQ.-1) THEN SETPPIN1.133
JTRACER=LOOKUP(40,I) SETPPIN1.134
PPINDEX(LOOKUP(42,I)) = I SETPPIN1.135
ENDIF SETPPIN1.136
SETPPIN1.137
ENDIF SETPPIN1.138
SETPPIN1.139
ENDDO SETPPIN1.140
SETPPIN1.141
! Check consistency between namelist and dumps. SETPPIN1.142
IF (.not.L_LSPICE .and. JQCF .NE. -1) THEN SETPPIN1.143
WRITE (6,*) ' ' SETPPIN1.144
WRITE (6,*) ' Inconsistency between namelist and dumps.' SETPPIN1.145
WRITE (6,*) ' Dump contains QCF.' SETPPIN1.146
WRITE (6,*) ' Namelist indicate that dumps have no QCF.' SETPPIN1.147
WRITE (6,*) ' Check namelist & dumps and rerun.' SETPPIN1.148
ICODE = 1 SETPPIN1.149
CMESSAGE = 'SETPPIN1: Inconsistency between dumps & namelist.' SETPPIN1.150
GO TO 9999 ! Return SETPPIN1.151
ENDIF SETPPIN1.152
SETPPIN1.153
IF (JPSTAR.EQ.-1 .or. JU.EQ.-1 .or. JV.EQ.-1 .or. SETPPIN1.154
& JTHETA.EQ.-1 .or. JQ.EQ.-1 .or. SETPPIN1.155
& (JQCF.EQ.-1 .and. L_LSPICE) ) THEN SETPPIN1.156
ICODE = 1 UDR3F405.197
write (6,*) ' PStar or U/V or THETA or Q or QCF not in dump.' UDR3F405.198
CMESSAGE = ' PStar or U/V or THETA or Q or QCF not in dump.' SETPPIN1.158
WRITE (6,*) ' JPSTAR = ',JPSTAR SETPPIN1.159
WRITE (6,*) ' JU = ',JU SETPPIN1.160
WRITE (6,*) ' JV = ',JV SETPPIN1.161
WRITE (6,*) ' JTHETA = ',JTHETA SETPPIN1.162
WRITE (6,*) ' JQ = ',JQ SETPPIN1.163
WRITE (6,*) ' JQCF = ',JQCF SETPPIN1.164
GO TO 9999 ! Return SETPPIN1.165
ENDIF SETPPIN1.166
SETPPIN1.167
! If no QCF, reset JQCF to prevent negative pointer. SETPPIN1.168
IF (JQCF .EQ. -1) THEN SETPPIN1.169
WRITE (6,*) ' ' SETPPIN1.170
WRITE (6,*) ' JQCF = ',JQCF SETPPIN1.171
WRITE (6,*) ' No QCF data in this dump.' SETPPIN1.172
JQCF = 1 SETPPIN1.173
ENDIF SETPPIN1.174
SETPPIN1.175
! If no Tracers, reset JTRACER to prevent negative pointer. SETPPIN1.176
IF (JTRACER .EQ. -1) THEN SETPPIN1.177
WRITE (6,*) ' ' SETPPIN1.178
WRITE (6,*) ' JTRACER = ',JTRACER SETPPIN1.179
WRITE (6,*) ' No tracer data in this dump.' SETPPIN1.180
JTRACER = 1 SETPPIN1.181
ENDIF SETPPIN1.182
SETPPIN1.183
9999 RETURN SETPPIN1.184
END SETPPIN1.185
*ENDIF SETPPIN1.186