*IF DEF,CONTROL POINTR1.2
C ******************************COPYRIGHT****************************** GTS2F400.12633
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.12634
C GTS2F400.12635
C Use, duplication or disclosure of this code is subject to the GTS2F400.12636
C restrictions as set forth in the contract. GTS2F400.12637
C GTS2F400.12638
C Meteorological Office GTS2F400.12639
C London Road GTS2F400.12640
C BRACKNELL GTS2F400.12641
C Berkshire UK GTS2F400.12642
C RG12 2SZ GTS2F400.12643
C GTS2F400.12644
C If no contract has been raised with this copy of the code, the use, GTS2F400.12645
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.12646
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.12647
C Modelling at the above address. GTS2F400.12648
C GTS2F400.12649
!+Change pointer system for "child" diags to final STASH list version POINTR1.3
! POINTR1.4
! Subroutine Interface: POINTR1.5
POINTR1.6
SUBROUTINE POINTR(NRECS) 1POINTR1.7
IMPLICIT NONE POINTR1.8
POINTR1.9
! Description: POINTR1.10
! The stash list with preliminary pointer system, and the stash POINTR1.11
! index, are input to this routine. The stash list with final POINTR1.12
! pointer system is output. POINTR1.13
! Called by STPROC. POINTR1.14
! POINTR1.15
! Fuller explanation: POINTR1.16
! Any diag in the stash list which has a processing code in the range POINTR1.17
! 2-7 (i.e., accumulate, time mean, append time series, max, min, POINTR1.18
! trajectory) has one or more "child records". A child is another POINTR1.19
! diag, with the same m,s,i. The output from the parent diag is used POINTR1.20
! as input to the child diag, which is then processed to produce POINTR1.21
! further output. Each child record has an entry which points to its POINTR1.22
! parent record - the st_input_code entry. In routine PRELIM, a POINTR1.23
! preliminary pointer system is set up, involving the use POINTR1.24
! of the "extra entry", NELEMP+1. In each record, entry NELEMP+1 is POINTR1.25
! set to the current value of NRECS, i.e., the position of that POINTR1.26
! record in the prelim stash list. The value of the st_input_code POINTR1.27
! entry for a child record is set to the negative of the NRECS value POINTR1.28
! for its parent. Note that, in the prelim stash list, the children POINTR1.29
! of a particular parent appear immediately after the parent. POINTR1.30
! So, after PRELIM, each record in the stash list identifies POINTR1.31
! itself by its NELEMP+1 entry, and each child record identifies POINTR1.32
! its parent by its st_input_code entry. The final position of POINTR1.33
! each record in the stash list is given by the INDX_S array. POINTR1.34
! This subroutine therefore changes the st_input_code entry of POINTR1.35
! each child record so that it agrees with INDX_S. POINTR1.36
! The NELEMP+1 entry is then no longer relevant. POINTR1.37
! POINTR1.38
! Method: POINTR1.39
! Uses INDX_S array to identify parent records (i.e., diagnostics POINTR1.40
! which have more than one entry in the stash list). POINTR1.41
! POINTR1.42
! Current code owner: S.J.Swarbrick POINTR1.43
! POINTR1.44
! History: POINTR1.45
! Version Date Comment POINTR1.46
! ======= ==== ======= POINTR1.47
! 3.5 Apr. 95 Original code. S.J.Swarbrick POINTR1.48
! POINTR1.49
! Code description: POINTR1.50
! FORTRAN 77 + common Fortran 90 extensions. POINTR1.51
! Written to UM programming standards version 7. POINTR1.52
! POINTR1.53
! System component covered: POINTR1.54
! System task: Sub-Models Project POINTR1.55
! POINTR1.56
! Global variables: POINTR1.57
POINTR1.58
*CALL CSUBMODL 
POINTR1.59
*CALL CPPXREF POINTR1.60
*CALL VERSION POINTR1.61
*CALL CSTASH GRB0F401.6
*CALL STEXTEND POINTR1.63
*CALL STPARAM POINTR1.64
POINTR1.66
! Subroutine arguments: POINTR1.67
POINTR1.68
! Scalar arguments with intent(in): POINTR1.69
POINTR1.70
INTEGER NRECS ! No. of records in stash list POINTR1.71
POINTR1.72
! Local scalars POINTR1.73
POINTR1.74
INTEGER MODL ! Loop counter for internal models POINTR1.75
INTEGER ISEC ! Do. sections POINTR1.76
INTEGER IITM ! Do. items POINTR1.77
INTEGER ISTR ! Position of parent record in stash list POINTR1.78
INTEGER IEND ! Position of final child record in stash list POINTR1.79
INTEGER I1 POINTR1.80
INTEGER I2 POINTR1.81
INTEGER I3 POINTR1.82
POINTR1.83
!- End of Header ---------------------------------------------------- POINTR1.84
POINTR1.85
! Loop over models, section, items POINTR1.86
POINTR1.87
DO MODL=1,N_INTERNAL_MODEL_MAX POINTR1.88
DO ISEC=0,NSECTP GSS1F400.1220
DO IITM=1,NITEMP GSS1F400.1221
POINTR1.91
! Examine INDX_S entry to find out whether there are child record(s) POINTR1.92
POINTR1.93
IF(INDX_S(2,MODL,ISEC,IITM).GE.2) THEN POINTR1.94
POINTR1.95
ISTR= INDX_S(1,MODL,ISEC,IITM) POINTR1.96
IEND=ISTR+INDX_S(2,MODL,ISEC,IITM)-1 POINTR1.97
POINTR1.98
DO I1=ISTR,IEND-1 POINTR1.99
DO I2=I1+1,IEND POINTR1.100
IF(LIST_S(st_input_code,I2).EQ. POINTR1.101
& -LIST_S(NELEMP+1 ,I1)) THEN POINTR1.102
LIST_S(st_input_code,I2)=-I1-NRECS POINTR1.103
END IF POINTR1.104
END DO POINTR1.105
END DO POINTR1.106
POINTR1.107
DO I3=ISTR,IEND POINTR1.108
IF(LIST_S(st_input_code,I3).LT.0) THEN POINTR1.109
LIST_S(st_input_code,I3)= POINTR1.110
& LIST_S(st_input_code,I3)+NRECS POINTR1.111
END IF POINTR1.112
END DO POINTR1.113
POINTR1.114
END IF POINTR1.115
POINTR1.116
END DO ! Items POINTR1.117
END DO ! Sections POINTR1.118
END DO ! Internal models POINTR1.119
POINTR1.120
RETURN POINTR1.121
END POINTR1.122
POINTR1.123
!- End of subroutine code --------------------------------------------- POINTR1.124
*ENDIF POINTR1.125