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