*IF DEF,CONTROL FINDPTR1.2
C ******************************COPYRIGHT****************************** GTS2F400.2935
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.2936
C GTS2F400.2937
C Use, duplication or disclosure of this code is subject to the GTS2F400.2938
C restrictions as set forth in the contract. GTS2F400.2939
C GTS2F400.2940
C Meteorological Office GTS2F400.2941
C London Road GTS2F400.2942
C BRACKNELL GTS2F400.2943
C Berkshire UK GTS2F400.2944
C RG12 2SZ GTS2F400.2945
C GTS2F400.2946
C If no contract has been raised with this copy of the code, the use, GTS2F400.2947
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.2948
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.2949
C Modelling at the above address. GTS2F400.2950
C ******************************COPYRIGHT****************************** GTS2F400.2951
C GTS2F400.2952
CLL Routine: FINDPTR ------------------------------------------------- FINDPTR1.3
CLL FINDPTR1.4
CLL Purpose: Locates address within D1 of diagnostic field which may FINDPTR1.5
CLL be required elsewhere in the model for special-purpose FINDPTR1.6
CLL diagnostic routine such as zonal mean print, or as an FINDPTR1.7
CLL internal interfacing field for coupling sub-models. FINDPTR1.8
CLL The search information is input in STASH format, and the FINDPTR1.9
CLL STASH list is scanned for a match. If the specified FINDPTR1.10
CLL field does not exist in D1 the address is returned as 0. FINDPTR1.11
CLL NB: Missing data indicators may be supplied if the search FINDPTR1.12
CLL is to ignore certain elements in the STASH list. FINDPTR1.13
CLL Tested under compiler: cft77 FINDPTR1.14
CLL Tested under OS version: UNICOS 5.1 FINDPTR1.15
CLL FINDPTR1.16
CLL FINDPTR1.17
CLL Author: T.C.Johns FINDPTR1.18
CLL FINDPTR1.19
CLL Code version no: 1.3 Date: 04 March 1992 FINDPTR1.20
CLL FINDPTR1.21
CLL Model Modification history from model version 3.0: FINDPTR1.22
CLL version Date FINDPTR1.23
CLL FINDPTR1.24
CLL 3.4 16/6/94 : Change CHARACTER*(*) to CHARACTER*(80) N.Farnon ANF0F304.11
CLL 3.5 June 95 Submodels project: GSS2F305.1
CLL Added internal_model to subroutine args. GSS2F305.2
CLL Altered args in each STINDEX reference. GSS2F305.3
CLL Changed hardwired addresses in each STLIST reference GSS2F305.4
CLL to parameter addresses as defined in STPARAM GSS2F305.5
CLL Added *CALL STPARAM GSS2F305.6
CLL S.J.Swarbrick GSS2F305.7
CLL GSS2F305.8
CLL Programming standard: UM Doc Paper 3, version 2 (7/9/90) FINDPTR1.25
CLL FINDPTR1.26
CLL Logical components covered: C610 FINDPTR1.27
CLL FINDPTR1.28
CLL Project task: C4? FINDPTR1.29
CLL FINDPTR1.30
CLL External documentation: FINDPTR1.31
CLL Unified Model Doc Paper C4 - Storage Handling and FINDPTR1.32
CLL Diagnostic System. FINDPTR1.33
CLL FINDPTR1.34
CLL ------------------------------------------------------------------- FINDPTR1.35
C*L Interface and arguments: ------------------------------------------ FINDPTR1.36
C FINDPTR1.37
SUBROUTINE FINDPTR ( internal_model,SECTION,ITEM, 98GSS2F305.9
* PROCESS_CODE,FREQ_CODE,START,END,PERIOD, FINDPTR1.39
* GRIDPT_CODE,WEIGHT_CODE, FINDPTR1.40
* BOTTOM_LEVEL,TOP_LEVEL, FINDPTR1.41
* GRID_N,GRID_S,GRID_W,GRID_E, FINDPTR1.42
* STASHMACRO_TAG,MDI,ADDRESS, @DYALLOC.898
*CALL ARGSIZE 
@DYALLOC.899
*CALL ARGSTS @DYALLOC.900
* ICODE,CMESSAGE) @DYALLOC.901
C FINDPTR1.46
IMPLICIT NONE FINDPTR1.47
C FINDPTR1.48
INTEGER FINDPTR1.49
* internal_model, ! IN - internal_model id. GSS2F305.10
* SECTION, ! IN - STASH section number FINDPTR1.50
* ITEM, ! IN - STASH item number FINDPTR1.51
* PROCESS_CODE, ! IN - STASH processing code FINDPTR1.52
* FREQ_CODE, ! IN - STASH frequency code FINDPTR1.53
* START, ! IN - STASH start step for processing FINDPTR1.54
* END, ! IN - STASH end step for processing FINDPTR1.55
* PERIOD, ! IN - STASH processing period FINDPTR1.56
* GRIDPT_CODE, ! IN - STASH gridpoint code FINDPTR1.57
* WEIGHT_CODE, ! IN - STASH weighting code FINDPTR1.58
* BOTTOM_LEVEL, ! IN - STASH input bottom level FINDPTR1.59
* TOP_LEVEL, ! IN - STASH input top level FINDPTR1.60
* GRID_N, ! IN - STASH N-row grid code FINDPTR1.61
* GRID_S, ! IN - STASH S-row grid code FINDPTR1.62
* GRID_W, ! IN - STASH W-col grid code FINDPTR1.63
* GRID_E, ! IN - STASH E-col grid code FINDPTR1.64
* STASHMACRO_TAG, ! IN - STASHmacro tag number FINDPTR1.65
* MDI, ! IN - Missing Data Indicator FINDPTR1.66
* ADDRESS, ! OUT - Address in D1 FINDPTR1.67
* ICODE ! OUT - Error return code FINDPTR1.68
CHARACTER*(80) ANF0F304.12
* CMESSAGE ! OUT - Error return message FINDPTR1.70
C FINDPTR1.71
C*---------------------------------------------------------------------- FINDPTR1.72
C Common blocks FINDPTR1.73
C FINDPTR1.74
*CALL CSUBMODL GSS2F305.11
*CALL TYPSIZE @DYALLOC.902
*CALL TYPSTS @DYALLOC.903
*CALL STPARAM GSS2F305.12
C FINDPTR1.79
C Local variables FINDPTR1.80
C FINDPTR1.81
INTEGER FINDPTR1.82
* ISTART,IEND,I, ! Start, end + loop index in STASHlist FINDPTR1.83
* NMATCH ! Number of matches found FINDPTR1.84
* ,im_index ! Internal model index GSS2F305.13
LOGICAL FINDPTR1.85
* MATCH ! TRUE if diagnostic matched FINDPTR1.86
CL---------------------------------------------------------------------- FINDPTR1.87
CL 0. Check that tag field is within the allowed range for user tags FINDPTR1.88
CL FINDPTR1.89
IF (STASHMACRO_TAG.NE.MDI .AND. FINDPTR1.90
& (STASHMACRO_TAG.LT.0 .OR. STASHMACRO_TAG.GT.999)) THEN FINDPTR1.91
CMESSAGE="FINDPTR : STASHMACRO_TAG must be in range 0-999" FINDPTR1.92
ICODE=ABS(STASHMACRO_TAG) FINDPTR1.93
GOTO 999 FINDPTR1.94
ENDIF FINDPTR1.95
CL---------------------------------------------------------------------- FINDPTR1.96
CL 1. Locate start/end limits within STASHlist for search; FINDPTR1.97
CL initialise output ADDRESS to zero FINDPTR1.98
CL FINDPTR1.99
ADDRESS=0 FINDPTR1.100
NMATCH=0 FINDPTR1.101
im_index=internal_model_index(internal_model) GSS2F305.14
IF (STINDEX(2,ITEM,SECTION,im_index).GT.0) THEN GSS2F305.15
ISTART=STINDEX(1,ITEM,SECTION,im_index) GSS2F305.16
IEND =STINDEX(2,ITEM,SECTION,im_index)+ISTART-1 GSS2F305.17
CL FINDPTR1.105
CL 1.1 Loop over STASHlist entries and try to find matches FINDPTR1.106
CL FINDPTR1.107
DO I=ISTART,IEND FINDPTR1.108
IF (STLIST(s_modl,I).NE.internal_model.OR. GSS2F305.18
& STLIST(s_sect,I).NE.SECTION.OR. GSS2F305.19
& STLIST(s_item,I).NE.ITEM) THEN GSS2F305.20
ICODE=1000*SECTION+ITEM FINDPTR1.110
CMESSAGE="FINDPTR : Corrupt STASHlist or STASHindex" FINDPTR1.111
GOTO 999 FINDPTR1.112
ENDIF FINDPTR1.113
MATCH=((STLIST(s_output,I).EQ.1).OR. GSS2F305.21
* (STLIST(s_output,I).EQ.2)).AND. GSS2F305.22
* (PROCESS_CODE.EQ.STLIST(s_proc,I) GSS2F305.23
* .OR.PROCESS_CODE.EQ.MDI).AND. GSS2F305.24
* (FREQ_CODE .EQ.STLIST( s_freq,I) GSS2F305.25
* .OR.FREQ_CODE .EQ.MDI) .AND. GSS2F305.26
* (START .EQ.STLIST( s_times,I) GSS2F305.27
* .OR.START .EQ.MDI) .AND. GSS2F305.28
* (END .EQ.STLIST( s_timee,I) GSS2F305.29
* .OR.END .EQ.MDI) .AND. GSS2F305.30
* (PERIOD .EQ.STLIST( s_period,I) GSS2F305.31
* .OR.PERIOD .EQ.MDI) .AND. GSS2F305.32
* (GRIDPT_CODE.EQ.STLIST( s_grid,I) GSS2F305.33
* .OR.GRIDPT_CODE.EQ.MDI) .AND. GSS2F305.34
* (WEIGHT_CODE.EQ.STLIST( s_weight,I) GSS2F305.35
* .OR.WEIGHT_CODE.EQ.MDI) .AND. GSS2F305.36
* (BOTTOM_LEVEL.EQ.STLIST(s_bottom,I) GSS2F305.37
* .OR.BOTTOM_LEVEL.EQ.MDI) .AND. GSS2F305.38
* (TOP_LEVEL .EQ.STLIST(s_top,I) GSS2F305.39
* .OR.TOP_LEVEL .EQ.MDI) .AND. GSS2F305.40
* (GRID_N .EQ.STLIST(s_north,I) GSS2F305.41
* .OR.GRID_N .EQ.MDI) .AND. GSS2F305.42
* (GRID_S .EQ.STLIST(s_south,I) GSS2F305.43
* .OR.GRID_S .EQ.MDI) .AND. GSS2F305.44
* (GRID_W .EQ.STLIST(s_west,I) GSS2F305.45
* .OR.GRID_W .EQ.MDI) .AND. GSS2F305.46
* (GRID_E .EQ.STLIST(s_east,I) GSS2F305.47
* .OR.GRID_E .EQ.MDI) .AND. GSS2F305.48
* (STASHMACRO_TAG.EQ.MOD(STLIST(st_macrotag,I),1000).OR. GSS2F305.49
* STASHMACRO_TAG.EQ.MDI) FINDPTR1.129
C FINDPTR1.130
IF (MATCH) THEN FINDPTR1.131
ADDRESS=STLIST(st_output_addr,I) GSS2F305.50
NMATCH=NMATCH+1 FINDPTR1.133
ENDIF FINDPTR1.134
ENDDO FINDPTR1.135
C FINDPTR1.136
IF (NMATCH.GT.1) THEN FINDPTR1.137
ICODE=-1000*SECTION-ITEM FINDPTR1.138
CMESSAGE="FINDPTR : Warning - multiple match for diagnostic" FINDPTR1.139
WRITE(6,*)"FINDPTR : Warning - multiple match for diagnostic ", GIE0F403.198
* SECTION,ITEM FINDPTR1.141
C FINDPTR1.142
ENDIF FINDPTR1.143
ENDIF FINDPTR1.144
C FINDPTR1.145
999 CONTINUE FINDPTR1.146
RETURN FINDPTR1.147
CL---------------------------------------------------------------------- FINDPTR1.148
END FINDPTR1.149
*ENDIF FINDPTR1.150