*IF DEF,C80_1A,OR,DEF,UTILIO,OR,DEF,RECON,OR,DEF,FLDOP UIE3F404.43
C ******************************COPYRIGHT****************************** GTS2F400.7561
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.7562
C GTS2F400.7563
C Use, duplication or disclosure of this code is subject to the GTS2F400.7564
C restrictions as set forth in the contract. GTS2F400.7565
C GTS2F400.7566
C Meteorological Office GTS2F400.7567
C London Road GTS2F400.7568
C BRACKNELL GTS2F400.7569
C Berkshire UK GTS2F400.7570
C RG12 2SZ GTS2F400.7571
C GTS2F400.7572
C If no contract has been raised with this copy of the code, the use, GTS2F400.7573
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.7574
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.7575
C Modelling at the above address. GTS2F400.7576
C ******************************COPYRIGHT****************************** GTS2F400.7577
C GTS2F400.7578
CLL SUBROUTINE PR_IFLD---------------------------------------- PRIFLD1A.3
CLL PRIFLD1A.4
CLL Purpose: Prints out selected values from integer data PRIFLD1A.5
CLL using information from associated PP header. PRIFLD1A.6
CLL PRIFLD1A.7
CLL Written by A. Dickinson PRIFLD1A.8
CLL PRIFLD1A.9
CLL Model Modification history from model version 3.0: PRIFLD1A.10
CLL version date PRIFLD1A.11
CLL 3.2 19/04/93 Code for new real missing data indicator. TJ050593.109
CLL Author: T.Johns Reviewer: A.Dickinson TJ050593.110
CLL 3.2 28/07/93 STOP WRITING OF FIELDS WHEN HEADERS ARE NOT SET. @DYALLOC.2947
CLL PRIFLD1A.12
CLL System component: R30/W30 PRIFLD1A.13
CLL PRIFLD1A.14
CLL System task: F3 PRIFLD1A.15
CLL PRIFLD1A.16
CLL Programming standard: PRIFLD1A.17
CLL Unified Model Documentation Paper No 3 PRIFLD1A.18
CLL Version No 1 15/1/90 PRIFLD1A.19
CLL PRIFLD1A.20
CLL Documentation: PRIFLD1A.21
CLL Unified Model Documentation Paper No F3 PRIFLD1A.22
CLL Version No 5 9/2/90 PRIFLD1A.23
CLL PRIFLD1A.24
CLL------------------------------------------------------------ PRIFLD1A.25
C*L Arguments:------------------------------------------------- PRIFLD1A.26
SUBROUTINE PR_IFLD(LOOKUP,RLOOKUP,ID1,K) 4PRIFLD1A.27
PRIFLD1A.28
IMPLICIT NONE PRIFLD1A.29
PRIFLD1A.30
INTEGER PRIFLD1A.31
* K !IN Field number ie position in 2nd dim PRIFLD1A.32
* ! of LOOKUP PRIFLD1A.33
*,LOOKUP(64,*) !IN Integer equivalence of PP LOOKUP PRIFLD1A.34
*,ID1(*) !IN Kth field in integer equiv of data array PRIFLD1A.35
PRIFLD1A.36
REAL PRIFLD1A.37
* RLOOKUP(64,*) !IN Real equivalence of PP LOOKUP PRIFLD1A.38
PRIFLD1A.39
C ------------------------------------------------------------- PRIFLD1A.40
C*L External subroutines called:------------------------------- PRIFLD1A.41
C None PRIFLD1A.42
C-------------------------------------------------------------- PRIFLD1A.43
C*L Local control constants:----------------------------------- PRIFLD1A.44
INTEGER PRIFLD1A.45
* NS_PTS !PARAM No of points down to print PRIFLD1A.46
*,EW_PTS !PARAM No of points across to print PRIFLD1A.47
PARAMETER(NS_PTS=6,EW_PTS=5) PRIFLD1A.48
C ------------------------------------------------------------- PRIFLD1A.49
C Workspace usage:--------------------------------------------- PRIFLD1A.50
REAL LON(EW_PTS) ! Longitudes printed out PRIFLD1A.51
INTEGER I(EW_PTS) ! Index of values printed out PRIFLD1A.52
CHARACTER*12 DASH(EW_PTS) !Stores dashed lines PRIFLD1A.53
C*------------------------------------------------------------- PRIFLD1A.54
C Local variables:--------------------------------------------- PRIFLD1A.55
INTEGER PRIFLD1A.56
* N_ROWS ! No of rows in field PRIFLD1A.57
*,N_COLS ! No of colums in field PRIFLD1A.58
*,ROW ! Row number PRIFLD1A.59
*,R_INC,F_INC ! No of rows/points between printed lines PRIFLD1A.60
*,J,L ! Loop counts PRIFLD1A.61
*,EW_PRINT ! No of E-W values printed out PRIFLD1A.62
*,POS_MIN ! Position of Minimum value of field PRIFLD1A.63
*,POS_MAX ! Position of Maximum value of field PRIFLD1A.64
*,F_MIN ! Minimum value of field PRIFLD1A.65
*,F_MAX ! Maximum value of field PRIFLD1A.66
PRIFLD1A.67
REAL PRIFLD1A.68
* LAT ! Latitude PRIFLD1A.69
C-------------------------------------------------------------- PRIFLD1A.70
PRIFLD1A.71
*CALL CLOOKADD 
PRIFLD1A.72
*CALL C_MDI @DYALLOC.2948
PRIFLD1A.73
CL Internal structure: None PRIFLD1A.74
PRIFLD1A.75
C Initialise string used to create table boundaries PRIFLD1A.76
DO 50 J=1,EW_PTS PRIFLD1A.77
50 DASH(J)='------------' PRIFLD1A.78
@DYALLOC.2949
IF(LOOKUP(LBCODE,K).EQ.IMDI) THEN @DYALLOC.2950
C IF LBCODE IS MISSING DATA, ASSUME THAT THE FIELD IN DUMP @DYALLOC.2951
C HAS NOT BEEN WRITTEN TO BY STASH. @DYALLOC.2952
C THIS SHOULD ONLY OCCUR TO DIAGNOSTIC PARTS OF THE DUMP BEFORE @DYALLOC.2953
C FIRST WRITE BY STASH TO THAT AREA/HEADER. @DYALLOC.2954
WRITE(6,*) 'MESSAGE FROM PR_IFLD' @DYALLOC.2955
WRITE(6,*) 'LBCODE NOT SET; ASSUME DATA NOT SET. NO PRINT' @DYALLOC.2956
RETURN @DYALLOC.2957
END IF @DYALLOC.2958
PRIFLD1A.79
C No of rows and columns in field PRIFLD1A.80
N_ROWS=LOOKUP(LBROW,K) PRIFLD1A.81
N_COLS=LOOKUP(LBNPT,K) PRIFLD1A.82
PRIFLD1A.83
PRIFLD1A.84
IF(N_COLS.NE.0.AND.N_COLS.NE.IMDI)THEN TJ050593.111
PRIFLD1A.86
C No of E-W values to be printed PRIFLD1A.87
EW_PRINT=MIN(N_COLS,EW_PTS) PRIFLD1A.88
PRIFLD1A.89
C Calculate longitudes and addresses of values to be printed from 1st ro PRIFLD1A.90
I(1)=1 PRIFLD1A.91
LON(1)=RLOOKUP(BZX,K)+RLOOKUP(BDX,K) PRIFLD1A.92
DO 100 J=1,EW_PTS-2 PRIFLD1A.93
I(J+1)=I(J)+N_COLS/(EW_PTS-1) PRIFLD1A.94
LON(J+1)=LON(J)+RLOOKUP(BDX,K)*(N_COLS/(EW_PTS-1)) PRIFLD1A.95
100 CONTINUE PRIFLD1A.96
I(EW_PTS)=N_COLS PRIFLD1A.97
LON(EW_PTS)=RLOOKUP(BZX,K)+RLOOKUP(BDX,K)*N_COLS PRIFLD1A.98
PRIFLD1A.99
C Initialise row and field pointers PRIFLD1A.100
ROW=1 PRIFLD1A.101
LAT=RLOOKUP(BZY,K)+RLOOKUP(BDY,K) PRIFLD1A.102
R_INC=N_ROWS/(NS_PTS-1) PRIFLD1A.103
F_INC=R_INC*N_COLS PRIFLD1A.104
PRIFLD1A.105
C Print 1st row PRIFLD1A.106
WRITE(6,'(14X,9A12)')(DASH(J),J=1,EW_PRINT) PRIFLD1A.107
WRITE(6,'('' FIELD NO'',I4,'':''9(F10.3,2X))') PRIFLD1A.108
*K,(LON(J),J=1,EW_PRINT) PRIFLD1A.109
WRITE(6,'(14X,9A12)')(DASH(J),J=1,EW_PRINT) PRIFLD1A.110
PRIFLD1A.111
C Print remaining rows except last PRIFLD1A.112
DO 200 L=1,NS_PTS-1 PRIFLD1A.113
WRITE(6,'(1X,I3,'':'',F8.3,'':'',3X,9(I9,3X))')ROW,LAT, PRIFLD1A.114
*(ID1(I(J)),J=1,EW_PRINT) PRIFLD1A.115
DO 300 J=1,EW_PTS PRIFLD1A.116
I(J)=I(J)+F_INC PRIFLD1A.117
300 CONTINUE PRIFLD1A.118
ROW=ROW+R_INC PRIFLD1A.119
LAT=LAT+R_INC*RLOOKUP(BDY,K) PRIFLD1A.120
200 CONTINUE PRIFLD1A.121
PRIFLD1A.122
C Calculate addresses used to print values for last row PRIFLD1A.123
I(1)=1+(N_ROWS-1)*N_COLS PRIFLD1A.124
DO 400 J=1,EW_PTS-2 PRIFLD1A.125
I(J+1)=I(J)+N_COLS/(EW_PTS-1) PRIFLD1A.126
400 CONTINUE PRIFLD1A.127
I(EW_PTS)=N_ROWS*N_COLS PRIFLD1A.128
PRIFLD1A.129
C Set row pointers to last row PRIFLD1A.130
LAT=RLOOKUP(BZY,K)+RLOOKUP(BDY,K)*N_ROWS PRIFLD1A.131
ROW=N_ROWS PRIFLD1A.132
PRIFLD1A.133
C Print last row PRIFLD1A.134
WRITE(6,'(1X,I3,'':'',F8.3,'':'',3X,9(I9,3X))')ROW,LAT, PRIFLD1A.135
*(ID1(I(J)),J=1,EW_PRINT) PRIFLD1A.136
WRITE(6,'(14X,9A12)')(DASH(J),J=1,EW_PRINT) PRIFLD1A.137
ELSE PRIFLD1A.138
PRIFLD1A.139
C Print out summary of non standard fields PRIFLD1A.140
PRIFLD1A.141
EW_PRINT=MIN(EW_PTS,LOOKUP(LBLREC,K)) PRIFLD1A.142
WRITE(6,'(14X,9A12)')(DASH(J),J=1,EW_PRINT) PRIFLD1A.143
WRITE(6,'('' FIELD NO'',I4,'': DATA NOT ON MODEL GRID'' PRIFLD1A.144
*,'' SO FIRST FEW VALUES PRINTED'')')K PRIFLD1A.145
WRITE(6,'(14X,9A12)')(DASH(J),J=1,EW_PRINT) PRIFLD1A.146
WRITE(6,'(1X,3X,'':'',8X,'':'',3X,9(I9,3X))') PRIFLD1A.147
*(ID1(J),J=1,EW_PRINT) PRIFLD1A.148
WRITE(6,'(14X,9A12)')(DASH(J),J=1,EW_PRINT) PRIFLD1A.149
PRIFLD1A.150
ENDIF PRIFLD1A.151
PRIFLD1A.152
PRIFLD1A.153
C Print out max and min values of field PRIFLD1A.154
F_MIN=ID1(1) PRIFLD1A.155
F_MAX=ID1(1) PRIFLD1A.156
POS_MAX=1 PRIFLD1A.157
POS_MIN=1 PRIFLD1A.158
DO 500 J=1,N_ROWS*N_COLS PRIFLD1A.159
IF(ID1(J).GT.F_MAX)THEN PRIFLD1A.160
F_MAX=ID1(J) PRIFLD1A.161
POS_MAX=J PRIFLD1A.162
ENDIF PRIFLD1A.163
IF(ID1(J).LT.F_MIN)THEN PRIFLD1A.164
F_MIN=ID1(J) PRIFLD1A.165
POS_MIN=J PRIFLD1A.166
ENDIF PRIFLD1A.167
500 CONTINUE PRIFLD1A.168
PRIFLD1A.169
WRITE(6,'('' MINIMUM='',I8,'' POSITION='',I8, PRIFLD1A.170
*'' MAXIMUM='',I8,'' POSITION='',I8)') PRIFLD1A.171
*F_MIN,POS_MIN,F_MAX,POS_MAX PRIFLD1A.172
PRIFLD1A.173
WRITE(6,'('' '')') PRIFLD1A.174
PRIFLD1A.175
RETURN PRIFLD1A.176
END PRIFLD1A.177
PRIFLD1A.178
*ENDIF PRIFLD1A.179