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