*IF DEF,C92_1A SPRALS1A.2
C ******************************COPYRIGHT****************************** GTS2F400.9433
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.9434
C GTS2F400.9435
C Use, duplication or disclosure of this code is subject to the GTS2F400.9436
C restrictions as set forth in the contract. GTS2F400.9437
C GTS2F400.9438
C Meteorological Office GTS2F400.9439
C London Road GTS2F400.9440
C BRACKNELL GTS2F400.9441
C Berkshire UK GTS2F400.9442
C RG12 2SZ GTS2F400.9443
C GTS2F400.9444
C If no contract has been raised with this copy of the code, the use, GTS2F400.9445
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.9446
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.9447
C Modelling at the above address. GTS2F400.9448
C ******************************COPYRIGHT****************************** GTS2F400.9449
C GTS2F400.9450
CLL SUBROUTINE SPIRAL_S----------------------------------------------- SPRALS1A.3
CLL SPRALS1A.4
CLL Written by C.P. Jones SPRALS1A.5
CLL SPRALS1A.6
CLL Reviewed by ?? SPRALS1A.7
CLL SPRALS1A.8
CLL Programming standard: SPRALS1A.9
CLL Unified Model Documentation Paper No 3 SPRALS1A.10
CLL SPRALS1A.11
CLL System component: S121 SPRALS1A.12
CLL SPRALS1A.13
CLL System task: S1 SPRALS1A.14
CLL SPRALS1A.15
CLL Purpose: SPRALS1A.16
CLL Attempts to set a value at points which are unresolved when SPRALS1A.17
CLL interpolating between one grid and another. A value is set SPRALS1A.18
CLL by finding the mean of surrounding points which do have data SPRALS1A.19
CLL set within a search radius determined by NSEARCH. SPRALS1A.20
CLL SPRALS1A.21
CLL Modification History: ANF1F400.17
CLL ANF1F400.18
CLL Model ANF1F400.19
CLL Version Date ANF1F400.20
CLL 4.0 02/11/95 The Fortran for squaring an array needed to be ANF1F400.21
CLL redefined for the DecAlpha because of lexcon. (N.Farnon) ANF1F400.22
CLL 4.4 23/09/97 amendment to calculation of row number and GMB0F404.1
CLL to check for missing data (M. J. Bell) GMB0F404.2
CLL Documentation: SPRALS1A.22
CLL UMDP S1 SPRALS1A.23
CLL SPRALS1A.24
CLL ------------------------------------------------------------- SPRALS1A.25
SUBROUTINE SPIRAL_S(LAND_SEA_MASK,INDEX_UNRES,NO_POINT_UNRES, 4SPRALS1A.26
& POINTS_PHI,POINTS_LAMBDA,DATA_FIELD,NSEARCH,SEA_LAND, SPRALS1A.27
& CYCLIC) SPRALS1A.28
SPRALS1A.29
IMPLICIT NONE SPRALS1A.30
SPRALS1A.31
C*L ARGUMENTS:--------------------------------------------------- SPRALS1A.32
SPRALS1A.33
INTEGER SPRALS1A.34
& POINTS_PHI !IN number of rows in grid SPRALS1A.35
&,POINTS_LAMBDA !IN number of columns in grid SPRALS1A.36
&,NSEARCH !IN number of points in each direction to search SPRALS1A.37
&,NO_POINT_UNRES !INOUT number of unresolved points SPRALS1A.38
&,LAND_SEA_MASK(POINTS_LAMBDA*POINTS_PHI) SPRALS1A.39
& !IN land sea mask SPRALS1A.40
&,INDEX_UNRES(POINTS_LAMBDA*POINTS_PHI) SPRALS1A.41
& !INOUT index to unresolved pts SPRALS1A.42
&,SEA_LAND !IN =0 for sea field =1/-1 for land field SPRALS1A.43
SPRALS1A.44
REAL SPRALS1A.45
& DATA_FIELD(POINTS_LAMBDA*POINTS_PHI) !INOUT field SPRALS1A.46
SPRALS1A.47
LOGICAL SPRALS1A.48
& CYCLIC ! IN =T if data covers complete latitude circle SPRALS1A.49
SPRALS1A.50
C*L Parameters GMB0F404.3
*CALL C_MDI 
GMB0F404.4
GMB0F404.5
C*L LOCAL VARIABLES SPRALS1A.51
SPRALS1A.52
INTEGER SPRALS1A.53
& I,J,JJ,JJJ,K,JK ! indices SPRALS1A.54
&,IPT,IROW,ICOL ! coordinate of unresolved point SPRALS1A.55
&,IPOINT,IUNRES ! do loop variable SPRALS1A.56
&,NPOINTS ! number of points in serach box SPRALS1A.57
&,IR((1+2*NSEARCH)*(1+2*NSEARCH)) ANF1F400.23
& ! row numbers of points to serach ANF1F400.24
&,IC((1+2*NSEARCH)*(1+2*NSEARCH)) ANF1F400.25
& ! col numbers of points to search ANF1F400.26
&,IND_SEARCH((1+2*NSEARCH)*(1+2*NSEARCH)) ANF1F400.27
& ! index to points to search ANF1F400.28
CLL ANF1F400.29
&,NOT_YET_SET ! number of points still to set SPRALS1A.61
&,IND_YET_SET(POINTS_LAMBDA*POINTS_PHI) ! index of points SPRALS1A.62
& ! still unresolved after calling this subroutine SPRALS1A.63
&,ISUM_MASK ! number of surrounding points which have data SPRALS1A.64
SPRALS1A.65
REAL SPRALS1A.66
& SUM_DATA ! sum of data surrounding unresolved points SPRALS1A.67
&, RMDI_TOL ! values within this tolerance counted as missing GMB0F404.6
SPRALS1A.68
C*L EXTERNAL ROUTINES SPRALS1A.69
C None SPRALS1A.70
C--------------------------------------------------------------------- GMB0F404.7
RMDI_TOL = ABS (RMDI) * 0.0001 GMB0F404.8
C SPRALS1A.71
SPRALS1A.72
C Calculate number of points in search box SPRALS1A.73
NPOINTS=(1+2*NSEARCH)**2 ! number of grid points in search box SPRALS1A.74
SPRALS1A.75
C Loop around unresolved points SPRALS1A.76
NOT_YET_SET=0 SPRALS1A.77
DO 10 IUNRES=1,NO_POINT_UNRES SPRALS1A.78
SPRALS1A.79
C find unresolved point coordinate in terms of rows and cols SPRALS1A.80
IPT=INDEX_UNRES(IUNRES) SPRALS1A.81
IROW= (IPT - 1)/POINTS_LAMBDA + 1 GMB0F404.9
ICOL=IPT-(IROW-1)*POINTS_LAMBDA SPRALS1A.83
SPRALS1A.84
C calculate surrounding points' coords in terms of rows and cols SPRALS1A.85
JJJ=1 SPRALS1A.86
DO 20 J=-NSEARCH,NSEARCH SPRALS1A.87
DO 30 JJ=JJJ,JJJ+2*NSEARCH SPRALS1A.88
IR(JJ)=IROW+J SPRALS1A.89
30 CONTINUE SPRALS1A.90
JJJ=JJJ+1+2*NSEARCH SPRALS1A.91
20 CONTINUE SPRALS1A.92
SPRALS1A.93
JJJ=1+2*NSEARCH SPRALS1A.94
JK=1 SPRALS1A.95
DO 40 J=-NSEARCH,NSEARCH SPRALS1A.96
DO 50 JJ=0,2*NSEARCH SPRALS1A.97
IC(JK+JJ*JJJ)=ICOL+J SPRALS1A.98
50 CONTINUE SPRALS1A.99
JK=JK+1 SPRALS1A.100
40 CONTINUE SPRALS1A.101
SPRALS1A.102
C Check that col and rows are in range of grid SPRALS1A.103
DO 70 IPOINT=1,NPOINTS SPRALS1A.104
IF(IC(IPOINT).GT.POINTS_LAMBDA) THEN SPRALS1A.105
IF(CYCLIC) THEN SPRALS1A.106
IC(IPOINT)=IC(IPOINT)-POINTS_LAMBDA SPRALS1A.107
ELSE SPRALS1A.108
IC(IPOINT)=POINTS_LAMBDA SPRALS1A.109
ENDIF SPRALS1A.110
ENDIF SPRALS1A.111
IF(IC(IPOINT).LT.1) THEN SPRALS1A.112
IF(CYCLIC) THEN SPRALS1A.113
IC(IPOINT)=IC(IPOINT)+POINTS_LAMBDA SPRALS1A.114
ELSE SPRALS1A.115
IC(IPOINT)=1 SPRALS1A.116
ENDIF SPRALS1A.117
ENDIF SPRALS1A.118
IF(IR(IPOINT).LT.1) IR(IPOINT)=1 SPRALS1A.119
IF(IR(IPOINT).GT.POINTS_PHI) IR(IPOINT)=POINTS_PHI SPRALS1A.120
70 CONTINUE SPRALS1A.121
SPRALS1A.122
c Form index search array SPRALS1A.123
DO 80 IPOINT=1,NPOINTS SPRALS1A.124
IND_SEARCH(IPOINT)=(IR(IPOINT)-1)*POINTS_LAMBDA+IC(IPOINT) SPRALS1A.125
80 CONTINUE SPRALS1A.126
SPRALS1A.127
C search for data around this point. If no data is found the point SPRALS1A.128
C remains unresolved SPRALS1A.129
SPRALS1A.130
ISUM_MASK=0 ! number of points with data found SPRALS1A.131
SUM_DATA=0.0 ! sum of data of surrounding grid points SPRALS1A.132
SPRALS1A.133
DO 90 IPOINT=1,NPOINTS SPRALS1A.134
IF(IABS(LAND_SEA_MASK(IND_SEARCH(IPOINT))).EQ.IABS(SEA_LAND) SPRALS1A.135
& .AND.DATA_FIELD(IND_SEARCH(IPOINT)) .GT. RMDI+RMDI_TOL) THEN GMB0F404.10
SUM_DATA=SUM_DATA+DATA_FIELD(IND_SEARCH(IPOINT)) SPRALS1A.137
ISUM_MASK=ISUM_MASK+1 SPRALS1A.138
ENDIF SPRALS1A.139
90 CONTINUE SPRALS1A.140
SPRALS1A.141
IF(ISUM_MASK .GT. 0) THEN GMB0F404.11
C data found - take mean SPRALS1A.143
DATA_FIELD(IPT)=SUM_DATA/REAL(ISUM_MASK) SPRALS1A.144
ELSE SPRALS1A.145
C data not found - point remains unresolved SPRALS1A.146
NOT_YET_SET=NOT_YET_SET+1 SPRALS1A.147
IND_YET_SET(NOT_YET_SET)=IPT SPRALS1A.148
ENDIF SPRALS1A.149
SPRALS1A.150
10 CONTINUE SPRALS1A.151
SPRALS1A.152
SPRALS1A.153
C amend output array with points remaining unresolved SPRALS1A.154
IF(NOT_YET_SET.GT.0) THEN SPRALS1A.155
DO 100 IPOINT=1,NOT_YET_SET SPRALS1A.156
INDEX_UNRES(IPOINT)=IND_YET_SET(IPOINT) SPRALS1A.157
100 CONTINUE SPRALS1A.158
NO_POINT_UNRES=NOT_YET_SET SPRALS1A.159
ELSE SPRALS1A.160
NO_POINT_UNRES=0 SPRALS1A.161
ENDIF SPRALS1A.162
RETURN SPRALS1A.163
END SPRALS1A.164
*ENDIF SPRALS1A.165