SUBROUTINE Var_Ctl( 1,5VARCTL1.6
*CALL ARGSIZE 
VARCTL1.7
*CALL ARGD1 VARCTL1.8
*CALL ARGDUMA VARCTL1.9
*CALL ARGSTS VARCTL1.10
*CALL ARGPTRA VARCTL1.11
*CALL ARGCONA VARCTL1.12
*CALL ARGPPX VSB1F400.581
& ErrorStatus,ErrorMessage) VARCTL1.13
VARCTL1.14
IMPLICIT NONE VARCTL1.15
! VARCTL1.16
! Description: VARCTL1.17
! Level 2 control routine VARCTL1.18
! Loop over Obs Files calling VAR_UMProcessing VARCTL1.19
! This additional control routine required so that dynamic space sizes VARCTL1.20
! can be passed to the lower level control routine and also to provide a VARCTL1.21
! *DEF CONTROL reference to the VAR outer loop code VARCTL1.22
! VARCTL1.23
! Method: VARCTL1.24
! The interface with ATMSTEP has been copied from AC_CTL VARCTL1.25
! VARCTL1.26
! Current Code Owner: Stuart Bell VARCTL1.27
! VARCTL1.28
! History: VARCTL1.29
! Version Date Comment VARCTL1.30
! ------- ---- ------- VARCTL1.31
! 3.4 1/8/94 Original code. Stuart Bell VARCTL1.32
! 4.0 6/6/95 Set X/YOffset. Stuart Bell VSB1F400.582
! 3.5 6/6/95 Sub-Model changes. Include Internal Model GDR4F305.402
! Identifier/Index. D. Robinson. GDR4F305.403
! 4.1 18/06/96 Changes to cope with changes in STASH addressing GDG0F401.1572
! Author D.M. Goddard. GDG0F401.1573
! 4.5 24/02/98 Allow Varobs input to be a directory. Stuart Bell VSB1F405.14
! VARCTL1.33
! Code Description: VARCTL1.34
! Language: FORTRAN 77 + common extensions VARCTL1.35
VARCTL1.36
! System component covered: P1 VARCTL1.37
! System Task: P0 VARCTL1.38
VARCTL1.39
! Declarations VARCTL1.40
VARCTL1.41
! Global variables (*CALLed COMDECKs etc...): VARCTL1.42
*CALL C_MDI VARCTL1.43
*CALL CSUBMODL GSS1F305.943
*CALL CMAXSIZE VARCTL1.44
*CALL TYPSIZE VARCTL1.45
*CALL CTIME VARCTL1.46
*CALL C_VARCTL VARCTL1.47
VARCTL1.48
! Subroutine arguments VARCTL1.49
! Scalar arguments with intent(in): VARCTL1.50
! & Array arguments with intent(in): VARCTL1.51
*CALL TYPD1 VARCTL1.52
*CALL TYPDUMA VARCTL1.53
*CALL TYPSTS VARCTL1.54
*CALL TYPPTRA VARCTL1.55
*CALL TYPCONA VARCTL1.56
*CALL PPXLOOK VSB1F400.583
VARCTL1.57
! ErrorStatus <Delete if ErrorStatus not used> VARCTL1.58
INTEGER ErrorStatus !Error flag (0 = OK) VARCTL1.59
CHARACTER*256 ErrorMessage !Error Message VARCTL1.60
VARCTL1.61
! Local parameters: VARCTL1.62
VARCTL1.63
! Local scalars: VARCTL1.64
INTEGER Jfile,J !loop counter VARCTL1.65
INTEGER JRH1P5M,JT1P5M,JU10M,JV10M !Start Addresses in D1 VARCTL1.66
INTEGER im_ident ! Internal Model Identifier GDR4F305.404
INTEGER im_index ! Internal Model Index GDR4F305.405
! define variables for OBS headers (would use DUM_LEN but VARCTL1.67
! LEN_FIXHD & LEN_DUMPHIST defined in COMDECK TYPSIZE) VARCTL1.68
INTEGER LEN_INTHD, LEN_REALHD VARCTL1.69
INTEGER LEN1_LEVDEPC, LEN2_LEVDEPC VARCTL1.70
INTEGER LEN1_ROWDEPC, LEN2_ROWDEPC VARCTL1.71
INTEGER LEN1_COLDEPC, LEN2_COLDEPC VARCTL1.72
INTEGER LEN1_FLDDEPC, LEN2_FLDDEPC VARCTL1.73
INTEGER LEN_EXTCNST VARCTL1.74
INTEGER LEN_CFI1, LEN_CFI2, LEN_CFI3 VARCTL1.75
INTEGER LEN1_LOOKUP_OBS, LEN2_LOOKUP_OBS VARCTL1.76
INTEGER LEN_DATA ! Length of data section of obs file VARCTL1.77
&,ICODE !Return code from setpos GTD0F400.139
VARCTL1.78
! Local dynamic arrays: VARCTL1.79
INTEGER FIXHD(LEN_FIXHD) ! Obs file fixed length header VARCTL1.80
VARCTL1.81
! Function & Subroutine calls: VARCTL1.82
External Var_UMProcessing, SETPOS, READ_FLH, GET_DIM VARCTL1.83
External HORIZ_GRID_OFFSET VSB1F400.584
VARCTL1.84
!- End of header VARCTL1.85
VARCTL1.86
im_ident = atmos_im GDR4F305.406
im_index = internal_model_index(im_ident) GDR4F305.407
GDR4F305.408
!----------------------------------------------------------------------- VARCTL1.87
DO J=1,NumModelVars VSB1F400.585
VSB1F400.586
! Get X/Y Offsets for this field to identify the grid VSB1F400.587
! (searching the fields tagged in the dump) VSB1F400.588
CALL HORIZ_GRID_OFFSET(ItemOut(J),0,im_ident, VSB1F400.589
& XOffset(J),YOffset(J), VSB1F400.590
*CALL ARGSTS VSB1F400.591
*CALL ARGPPX VSB1F400.592
& ErrorStatus) VSB1F400.593
VSB1F400.594
IF (ErrorStatus .GT. 0) THEN VSB1F400.595
ErrorMessage = "VarCtl: Problem in HORIZ_GRID_OFFSET" VSB1F400.596
GOTO 999 VSB1F400.597
END IF VSB1F400.598
VSB1F400.599
END DO !J VSB1F400.600
VSB1F400.601
!----------------------------------------------------------------------- VSB1F400.602
! Loop over observation files VARCTL1.88
DO Jfile = 1, NumUsedFiles VSB1F405.15
VARCTL1.90
!----------------------------------------------------------------------- VARCTL1.91
! Portable I/O open for 'dump type' VAROBS file VSB1F405.16
CALL FILE_OPEN (ObsUnitNum, VSB1F405.17
& NameUsedFile(Jfile),LenUsedFile(Jfile), VSB1F405.18
& 0,1,ErrorStatus) VSB1F405.19
IF (ErrorStatus.GT.0) GO TO 999 VSB1F405.20
VARCTL1.94
!----------------------------------------------------------------------- VARCTL1.95
! Read in fixed length header VARCTL1.96
CALL READ_FLH (ObsUnitNum,FIXHD,LEN_FIXHD, VSB1F405.21
& ErrorStatus,ErrorMessage) VARCTL1.98
IF (ErrorStatus.GT.0) GO TO 999 VARCTL1.99
VARCTL1.100
!----------------------------------------------------------------------- VARCTL1.101
! Get dimensions of all data set components from FLH VARCTL1.102
CALL GET_DIM (FIXHD, VARCTL1.103
*CALL DUMP_AR2 VARCTL1.104
& LEN_DATA) VARCTL1.105
VARCTL1.106
!----------------------------------------------------------------------- VARCTL1.107
! Set the D1 pointers which are not already in TYPPTRA VARCTL1.108
JU10M = IMDI VARCTL1.109
JV10M = IMDI VARCTL1.110
JT1P5M = IMDI VARCTL1.111
JRH1P5M = IMDI VARCTL1.112
VARCTL1.113
DO J=1,NumModelVars VARCTL1.114
IF(SectionIN(J).EQ.3.AND.ItemIn(J).EQ.225) VARCTL1.115
& JU10M=SI(ItemOut(J),0,im_index) GDR4F305.409
IF(SectionIN(J).EQ.3.AND.ItemIn(J).EQ.226) VARCTL1.117
& JV10M=SI(ItemOut(J),0,im_index) GDR4F305.410
IF(SectionIN(J).EQ.3.AND.ItemIn(J).EQ.236) VARCTL1.119
& JT1P5M=SI(ItemOut(J),0,im_index) GDR4F305.411
IF(SectionIN(J).EQ.3.AND.ItemIn(J).EQ.245) VARCTL1.121
& JRH1P5M=SI(ItemOut(J),0,im_index) GDR4F305.412
END DO VARCTL1.123
VARCTL1.124
IF(JU10M.EQ.IMDI) ErrorStatus=1 VARCTL1.125
IF(JV10M.EQ.IMDI) ErrorStatus=1 VARCTL1.126
IF(JT1P5M.EQ.IMDI) ErrorStatus=1 VARCTL1.127
IF(JRH1P5M.EQ.IMDI)ErrorStatus=1 VARCTL1.128
VARCTL1.129
IF (ErrorStatus.EQ.1)THEN VARCTL1.130
ErrorMessage = ' Var_Ctl: Fields missing' VARCTL1.131
GO TO 999 VARCTL1.132
END IF VARCTL1.133
!----------------------------------------------------------------------- VARCTL1.134
! Call Var processing (section 18 code) VARCTL1.135
CALL Var_UMProcessing(Jfile, VARCTL1.136
*CALL DUMP_AR2 VARCTL1.137
& LEN_DATA, VARCTL1.138
& A_REALHD(1), VARCTL1.139
& P_LEVELS, Q_LEVELS, ROW_LENGTH, VARCTL1.140
& P_ROWS, U_ROWS, P_FIELD, U_FIELD, VARCTL1.141
& A_LEVDEPC(JAK), A_LEVDEPC(JBK), AKH, BKH, VARCTL1.142
& D1(JOROG), D1(JP_EXNER(1)), D1(JPSTAR), VARCTL1.143
& D1(JTHETA(1)), D1(JQ(1)), D1(JU(1)), D1(JV(1)), VARCTL1.144
& D1(JQCF(1)), D1(JQCL(1)), VARCTL1.145
& D1(JU10M), D1(JV10M), D1(JT1P5M), D1(JRH1P5M), VARCTL1.146
*CALL ARGPPX GDG0F401.1574
& ErrorStatus,ErrorMessage) VARCTL1.147
IF (ErrorStatus.GT.0) GO TO 999 VARCTL1.148
VARCTL1.149
!----------------------------------------------------------------------- VSB1F405.22
! Portable I/O close for 'dump type' VAROBS file VSB1F405.23
CALL FILE_CLOSE (ObsUnitNum, VSB1F405.24
& NameUsedFile(Jfile),LenUsedFile(Jfile), VSB1F405.25
& 1,0,ErrorStatus) VSB1F405.26
VSB1F405.27
END DO !JFile VARCTL1.150
VARCTL1.151
999 CONTINUE VARCTL1.152
RETURN VARCTL1.153
END VARCTL1.154
*ENDIF VARCTL1.155