SUBROUTINE Var_Copy( 1,2VARCOPY1.6
*CALL ARGSIZE 
VARCOPY1.7
*CALL ARGD1 VARCOPY1.8
*CALL ARGDUMA VARCOPY1.9
*CALL ARGSTS VARCOPY1.10
*CALL ARGPTRA VARCOPY1.11
*CALL ARGCONA VARCOPY1.12
*CALL ARGPPX GSS2F305.73
& ErrorStatus,ErrorMessage) VARCOPY1.13
VARCOPY1.14
IMPLICIT NONE VARCOPY1.15
! VARCOPY1.16
! Description: VARCOPY1.17
! Level 2 control routine VARCOPY1.18
! Loops over calls to FINDPTR to get addressing for STASHMACRO_TAG space VARCOPY1.19
! and copy into appropriate slot in prognostic space VARCOPY1.20
! VARCOPY1.21
! Method: VARCOPY1.22
! The interface with ATMSTEP and the usage of FINDPTR VARCOPY1.23
! has been copied from AC_CTL VARCOPY1.24
! VARCOPY1.25
! Current Code Owner: Stuart Bell VARCOPY1.26
! VARCOPY1.27
! History: VARCOPY1.28
! Version Date Comment VARCOPY1.29
! ------- ---- ------- VARCOPY1.30
! 3.4 1/8/94 Original code. Stuart Bell VARCOPY1.31
! 4.0 12/6/95 Wrong argument list, HORIZ_GRID_OFFSET call. S Bell VSB1F400.578
! 3.5 June 95 Submodels project. Added *CALL ARGPPX, GSS2F305.74
! *CALL PPXLOOK to pass ppx lookup arrays GSS2F305.75
! to HORIZ_GRID_OFFSET. GSS2F305.76
! Altered arguments in SI array reference. GSS2F305.77
! S.J.Swarbrick GSS2F305.78
! 4.1 4/01/96 Multiply Lenfield by ItemLevels(J) to allow for VSB1F401.119
! multi-level fields. Adam Clayton VSB1F401.120
! VARCOPY1.32
! Code Description: VARCOPY1.33
! Language: FORTRAN 77 + common extensions VARCOPY1.34
VARCOPY1.35
! System component covered: P1 VARCOPY1.36
! System Task: P0 VARCOPY1.37
VARCOPY1.38
! Declarations VARCOPY1.39
VARCOPY1.40
! Global variables (*CALLed COMDECKs etc...): VARCOPY1.41
*CALL CMAXSIZE VARCOPY1.42
*CALL CSUBMODL GSS2F305.79
*CALL TYPSIZE VARCOPY1.43
*CALL CTIME VARCOPY1.44
*CALL C_VARCTL VARCOPY1.45
*CALL C_MDI VARCOPY1.46
VARCOPY1.47
! Subroutine arguments VARCOPY1.48
! Scalar arguments with intent(in): VARCOPY1.49
! & Array arguments with intent(in): VARCOPY1.50
*CALL TYPD1 VARCOPY1.51
*CALL TYPDUMA VARCOPY1.52
*CALL TYPSTS VARCOPY1.53
*CALL TYPPTRA VARCOPY1.54
*CALL TYPCONA VARCOPY1.55
*CALL PPXLOOK GSS2F305.80
VARCOPY1.56
! ErrorStatus <Delete if ErrorStatus not used> VARCOPY1.57
INTEGER ErrorStatus !Error flag (0 = OK) VARCOPY1.58
CHARACTER*256 ErrorMessage !Error Message VARCOPY1.59
VARCOPY1.60
! Local parameters: VARCOPY1.61
VARCOPY1.62
! Local scalars: VARCOPY1.63
INTEGER J ! loop counter over fields VARCOPY1.64
INTEGER Len ! loop counter over points in field VARCOPY1.65
INTEGER LenField ! No of points in field VARCOPY1.66
INTEGER MDI ! missing data indicator VARCOPY1.67
INTEGER StashmacroTag ! Stash Macro Tag VARCOPY1.68
INTEGER AddressIn ! Address of field in StashMacro space VARCOPY1.69
INTEGER im_index ! Internal model index GSS2F305.81
VARCOPY1.70
! Local dynamic arrays: VARCOPY1.71
VARCOPY1.72
! Function & Subroutine calls: VARCOPY1.73
External FINDPTR, HORIZ_GRID_OFFSET VARCOPY1.74
VARCOPY1.75
!- End of header VARCOPY1.76
VARCOPY1.77
!----------------------------------------------------------------------- VARCOPY1.78
! NOTES: VARCOPY1.79
! a) It might be tidier if we identified all the fields with the VARCOPY1.80
! relevant StashMacroTag set and copied them in turn to the fields VARCOPY1.81
! addressed by SI(>280,0). This would avoid hardwiring in the code. VARCOPY1.82
! We would then simply be reliant on the correct UI settings VARCOPY1.83
! b) The number of levels of data to be copied is currently VSB1F401.121
! hardwired as ItemLevels(:). It would perhaps be a good idea to check VSB1F401.122
! that ItemLevels(J) is consistent with the STASH setup in the UI. VSB1F401.123
! c) We should perhaps check that the StashIndex for input and VARCOPY1.86
! output fields match where this is required VARCOPY1.87
! d) We should check that the output address specified by VARCOPY1.88
! SI(>280,0) is valid VARCOPY1.89
!----------------------------------------------------------------------- VARCOPY1.90
VARCOPY1.91
MDI = IMDI VARCOPY1.92
StashMacroTag = 31 VARCOPY1.93
VARCOPY1.94
DO J=1,NumModelVars VARCOPY1.95
VARCOPY1.96
! Get address for each field from its STASH section/item code VARCOPY1.97
! and STASHmacro tag (searching only on STASHmacro tag) VARCOPY1.98
IF(SectionIn(J).GT.0)THEN VARCOPY1.99
CALL FINDPTR (A_IM,SectionIn(J),ItemIn(J), GSS2F305.82
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, VARCOPY1.101
& StashmacroTag,MDI,AddressIn, VARCOPY1.102
*CALL ARGSIZE VARCOPY1.103
*CALL ARGSTS VARCOPY1.104
& ErrorStatus,ErrorMessage) VARCOPY1.105
VARCOPY1.106
IF (AddressIn .EQ. 0) THEN VARCOPY1.107
ErrorStatus = SectionIn(J)*1000+ItemIn(J) VARCOPY1.108
ErrorMessage = "VarCopy: Field not available" VARCOPY1.109
GOTO 999 VARCOPY1.110
END IF VARCOPY1.111
VARCOPY1.112
! Get X/Y Offsets for this field to identify the grid VARCOPY1.113
CALL HORIZ_GRID_OFFSET(ItemIn(J),SectionIn(J),A_IM, GSS2F305.83
& XOffset(J),YOffset(J), VSB1F400.579
*CALL ARGSTS VARCOPY1.115
*CALL ARGPPX GSS2F305.84
& ErrorStatus) VSB1F400.580
VARCOPY1.117
IF (ErrorStatus .GT. 0) THEN VARCOPY1.118
ErrorMessage = "VarCopy: Problem in HORIZ_GRID_OFFSET" VARCOPY1.119
GOTO 999 VARCOPY1.120
END IF VARCOPY1.121
VARCOPY1.122
IF(YOffset(J).EQ.0.)THEN VARCOPY1.123
Lenfield = P_FIELD VARCOPY1.124
ELSE VARCOPY1.125
Lenfield = U_FIELD VARCOPY1.126
ENDIF VARCOPY1.127
Lenfield = Lenfield*ItemLevels(J) VSB1F401.124
VARCOPY1.128
IF (ItemOut(J) .GT. NITEMS) THEN VARCOPY1.129
ErrorStatus = ItemOut(J) VARCOPY1.130
ErrorMessage = "VarCopy: Space not available to copy" VARCOPY1.131
GOTO 999 VARCOPY1.132
END IF VARCOPY1.133
VARCOPY1.134
im_index=internal_model_index(A_IM) GSS2F305.85
DO Len = 1, LenField VARCOPY1.135
D1(SI(ItemOut(J),0,im_index)+Len-1)=D1(AddressIn+Len-1) GSS2F305.86
END DO !Len VARCOPY1.137
VARCOPY1.138
END IF ! >section 0 VARCOPY1.139
VARCOPY1.140
END DO !J VARCOPY1.141
VARCOPY1.142
999 CONTINUE VARCOPY1.143
RETURN VARCOPY1.144
END VARCOPY1.145
*ENDIF VARCOPY1.146