*IF DEF,C70_1A,OR,DEF,RECON,OR,DEF,FLDOP GLW1F404.28
C ******************************COPYRIGHT****************************** GTS2F400.3241
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.3242
C GTS2F400.3243
C Use, duplication or disclosure of this code is subject to the GTS2F400.3244
C restrictions as set forth in the contract. GTS2F400.3245
C GTS2F400.3246
C Meteorological Office GTS2F400.3247
C London Road GTS2F400.3248
C BRACKNELL GTS2F400.3249
C Berkshire UK GTS2F400.3250
C RG12 2SZ GTS2F400.3251
C GTS2F400.3252
C If no contract has been raised with this copy of the code, the use, GTS2F400.3253
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.3254
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.3255
C Modelling at the above address. GTS2F400.3256
C ******************************COPYRIGHT****************************** GTS2F400.3257
C GTS2F400.3258
CLL SUBROUTINE F_TYPE----------------------------------------------- F_TYPE1.3
CLL F_TYPE1.4
CLL Purpose: Returns each field code and associated field length from F_TYPE1.5
CLL the PP header and a count of the number of fields F_TYPE1.6
CLL of each type. F_TYPE1.7
CLL F_TYPE1.8
CLL Written by A. Dickinson F_TYPE1.9
CLL F_TYPE1.10
CLL Model Modification history from model version 3.0: F_TYPE1.11
CLL version Date F_TYPE1.12
CLL F_TYPE1.13
CLL 3.1 05/02/93 Trap use of user defined PPXREF file AD050293.63
CLL Author: A. Dickinson Reviewer: R. Stratton AD050293.64
CLL 3.4 16/6/94 : Change CHARACTER*(*) to CHARACTER*(80) N.Farnon ANF0F304.13
CLL 3.5 May 95 Submodels project. Replace call to RDPPXRF by GSS1F305.168
CLL function EXPPXC to extract name of diagnostic GSS1F305.169
CLL item. S.J.Swarbrick GSS1F401.51
CLL 4.1 Apr. 96 Rationalise *CALLs S.J.Swarbrick GSS1F401.52
CLL 4.4 28/10/97 Change format of printout. D. Robinson. GDR7F404.481
CLL AD050293.65
CLL Programming standard : F_TYPE1.14
CLL F_TYPE1.15
CLL Logical components covered : F_TYPE1.16
CLL F_TYPE1.17
CLL Project task : F_TYPE1.18
CLL F_TYPE1.19
CLL Documentation: None F_TYPE1.20
CLL F_TYPE1.21
CLLEND---------------------------------------------------------------- F_TYPE1.22
C F_TYPE1.23
C*L Arguments:------------------------------------------------------- F_TYPE1.24
SUBROUTINE F_TYPE(LOOKUP,LEN2_LOOKUP,PP_NUM,N_TYPES 9,1F_TYPE1.25
*,PP_LEN,PP_STASH,PP_TYPE,PP_POS,PP_LS,FIXHD, GSS1F305.172
*CALL ARGPPX 
GSS1F305.173
*TITLE) GSS1F305.174
F_TYPE1.27
IMPLICIT NONE F_TYPE1.28
F_TYPE1.29
INTEGER F_TYPE1.30
* LEN2_LOOKUP !IN 2nd dimension of LOOKUP F_TYPE1.31
*,N_TYPES !IN No of separate field types in file F_TYPE1.32
*,LOOKUP(64,LEN2_LOOKUP) !IN LOOKUP record F_TYPE1.33
*,PP_NUM(LEN2_LOOKUP) !OUT No of successive fields with same co F_TYPE1.34
*,PP_LEN(LEN2_LOOKUP) !OUT Length of field F_TYPE1.35
*,PP_STASH(LEN2_LOOKUP) !OUT PP code of field F_TYPE1.36
*,PP_TYPE(LEN2_LOOKUP) !OUT Integer/real/timeseries F_TYPE1.37
*,PP_POS(LEN2_LOOKUP) !OUT Pointer to number of PP field F_TYPE1.38
*,PP_LS(LEN2_LOOKUP) !OUT Data stored on land or sea pts F_TYPE1.39
*,FIXHD(*) F_TYPE1.40
F_TYPE1.41
CHARACTER*(80)TITLE ANF0F304.14
F_TYPE1.43
F_TYPE1.44
C Comdecks: ------------------------------------------------------------ F_TYPE1.45
*CALL CSUBMODL GSS1F305.175
*CALL CPPXREF F_TYPE1.46
*CALL PPXLOOK GSS1F305.177
C Local variables: ----------------------------------------------------- GSS1F305.178
INTEGER MODEL !Internal model number from LOOKUP GSS1F305.179
F_TYPE1.47
C Local arrays:--------------------------------------------------------- F_TYPE1.48
INTEGER F_TYPE1.49
* PP_XREF(PPXREF_CODELEN) !PPXREF codes for a given section/item F_TYPE1.50
F_TYPE1.51
C External subroutines called:------------------------------------------ F_TYPE1.52
CHARACTER*36 EXPPXC GSS1F305.180
EXTERNAL EXPPXC,ABORT_IO GSS1F305.181
C*---------------------------------------------------------------------- F_TYPE1.54
C*L Local variables:--------------------------------------------------- F_TYPE1.55
INTEGER F_TYPE1.56
* ICODE ! Error code F_TYPE1.57
*,ITEM_CODE ! STASH item code F_TYPE1.58
*,SECTION ! STASH section number F_TYPE1.59
F_TYPE1.60
CHARACTER F_TYPE1.61
* CMESSAGE*80 ! Error message F_TYPE1.62
*,PHRASE*(PPXREF_CHARLEN) ! Name of field F_TYPE1.63
F_TYPE1.64
INTEGER I,K F_TYPE1.65
C*---------------------------------------------------------------------- F_TYPE1.66
F_TYPE1.67
C Initialise arrays F_TYPE1.68
DO K=1,LEN2_LOOKUP F_TYPE1.69
PP_NUM(K)=1 F_TYPE1.70
PP_LEN(K)=0 F_TYPE1.71
PP_STASH(K)=0 F_TYPE1.72
PP_TYPE(K)=0 F_TYPE1.73
PP_POS(K)=0 F_TYPE1.74
PP_LS(K)=0 F_TYPE1.75
ENDDO F_TYPE1.76
F_TYPE1.77
N_TYPES=1 F_TYPE1.78
PP_LEN(1)=LOOKUP(15,1) F_TYPE1.79
PP_STASH(1)=LOOKUP(42,1) F_TYPE1.80
PP_TYPE(1)=LOOKUP(39,1) F_TYPE1.81
PP_POS(1)=1 F_TYPE1.82
IF(MOD(INT(LOOKUP(21,1)/10),10).EQ.2)THEN F_TYPE1.83
PP_LS(1)=MOD(INT(LOOKUP(21,1)/100),10) F_TYPE1.84
ENDIF F_TYPE1.85
F_TYPE1.86
DO K=2,LEN2_LOOKUP F_TYPE1.87
IF(LOOKUP(42,K).EQ.LOOKUP(42,K-1).AND. F_TYPE1.88
& LOOKUP(15,K).EQ.LOOKUP(15,K-1))THEN F_TYPE1.89
PP_NUM(N_TYPES)=PP_NUM(N_TYPES)+1 F_TYPE1.90
ELSE F_TYPE1.91
N_TYPES=N_TYPES+1 F_TYPE1.92
PP_LEN(N_TYPES)=LOOKUP(15,K) F_TYPE1.93
PP_STASH(N_TYPES)=LOOKUP(42,K) F_TYPE1.94
PP_TYPE(N_TYPES)=LOOKUP(39,K) F_TYPE1.95
PP_POS(N_TYPES)=PP_POS(N_TYPES-1)+PP_NUM(N_TYPES-1) F_TYPE1.96
IF(MOD(INT(LOOKUP(21,K)/10),10).EQ.2)THEN F_TYPE1.97
PP_LS(N_TYPES)=MOD(INT(LOOKUP(21,K)/100),10) F_TYPE1.98
ENDIF F_TYPE1.99
ENDIF F_TYPE1.100
ENDDO F_TYPE1.101
F_TYPE1.102
C Print out details of fields F_TYPE1.103
WRITE(6,'('' '',/,'' '',A/)')TITLE GSS1F305.182
I=1 F_TYPE1.105
DO K=1,N_TYPES F_TYPE1.106
PHRASE=' ' F_TYPE1.107
ITEM_CODE=MOD(LOOKUP(42,I),1000) F_TYPE1.108
SECTION=(LOOKUP(42,I)-ITEM_CODE)/1000 F_TYPE1.109
MODEL=LOOKUP(45,I) GSS1F305.183
PHRASE=EXPPXC(MODEL,SECTION,ITEM_CODE, GSS1F305.184
*CALL ARGPPX GSS1F305.185
& ICODE,CMESSAGE) GSS1F305.186
! IF(ICODE.NE.0)THEN GSS1F305.187
! IF(ICODE.EQ.100)THEN GSS1F305.188
! PHRASE='NON-STANDARD FIELD' GSS1F305.189
! ELSE GSS1F305.190
! CALL ABORT_IO('F_TYPE',CMESSAGE,ICODE,1) GSS1F305.191
! ENDIF GSS1F305.192
! ENDIF GSS1F305.193
I=I+PP_NUM(K) F_TYPE1.115
WRITE(6,'('' '',I4,I5,I8,I4,2I6,2x,A36)') GDR7F404.482
& PP_LS(K),PP_NUM(K),PP_LEN(K) GDR7F404.483
* ,PP_TYPE(K),PP_STASH(K),PP_POS(K),PHRASE F_TYPE1.117
ENDDO F_TYPE1.118
F_TYPE1.119
RETURN F_TYPE1.120
END F_TYPE1.121
*ENDIF F_TYPE1.122