*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.15
*IF DEF,A01_3A,OR,DEF,A02_3A COLSF3A.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13178
C GTS2F400.13179
C Use, duplication or disclosure of this code is subject to the GTS2F400.13180
C restrictions as set forth in the contract. GTS2F400.13181
C GTS2F400.13182
C Meteorological Office GTS2F400.13183
C London Road GTS2F400.13184
C BRACKNELL GTS2F400.13185
C Berkshire UK GTS2F400.13186
C RG12 2SZ GTS2F400.13187
C GTS2F400.13188
C If no contract has been raised with this copy of the code, the use, GTS2F400.13189
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13190
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13191
C Modelling at the above address. GTS2F400.13192
C ******************************COPYRIGHT****************************** GTS2F400.13193
C GTS2F400.13194
!+ Subroutine to assemble lists of points with the same surfaces. COLSF3A.3
! COLSF3A.4
! Method: COLSF3A.5
! The surfaces at the bottom of each profile are examined COLSF3A.6
! and lists of points with the same type of surface are made. COLSF3A.7
! COLSF3A.8
! Current Owner of Code: J. M. Edwards COLSF3A.9
! COLSF3A.10
! History: COLSF3A.11
! Version Date Comment COLSF3A.12
! 4.0 27-07-95 Original Code COLSF3A.13
! (J. M. Edwards) COLSF3A.14
! 4.2 Nov. 96 T3E migration: CALL WHENEQ replaced GSS2F402.221
! by portable fortran code. GSS2F402.222
! S.J.Swarbrick GSS2F402.223
! COLSF3A.15
! Description of Code: COLSF3A.16
! FORTRAN 77 with extensions listed in documentation. COLSF3A.17
! COLSF3A.18
!- --------------------------------------------------------------------- COLSF3A.19
SUBROUTINE COLLECT_SURFACE(N_PROFILE 1COLSF3A.20
& , I_SURFACE COLSF3A.21
& , N_POINT_TYPE, INDEX_SURFACE COLSF3A.22
& , NPD_PROFILE, NPD_SURFACE COLSF3A.23
& ) COLSF3A.24
! COLSF3A.25
! COLSF3A.26
IMPLICIT NONE COLSF3A.27
! COLSF3A.28
! COLSF3A.29
! SIZES OF DUMMY ARRAYS. COLSF3A.30
INTEGER !, INTENT(IN) COLSF3A.31
& NPD_PROFILE COLSF3A.32
! MAXIMUM NUMBER OF PROFILES COLSF3A.33
& , NPD_SURFACE COLSF3A.34
! MAXIMUM NUMBER OF SURFACES COLSF3A.35
! COLSF3A.36
! DUMMY ARGUMENTS. COLSF3A.37
INTEGER !, INTENT(IN) COLSF3A.38
& N_PROFILE COLSF3A.39
! NUMBER OF PROFILES COLSF3A.40
& , I_SURFACE(NPD_PROFILE) COLSF3A.41
! SURFACE SPECIFICATIONS COLSF3A.42
INTEGER !, INTENT(OUT) COLSF3A.43
& N_POINT_TYPE(NPD_SURFACE) COLSF3A.44
! NUMBER OF POINTS OF EEACH TYPE COLSF3A.45
& , INDEX_SURFACE(NPD_PROFILE, NPD_SURFACE) COLSF3A.46
! LIST OF POINTS OF EACH TYPE COLSF3A.47
! COLSF3A.48
! LOCAL VARIABLES. COLSF3A.49
INTEGER COLSF3A.50
& L COLSF3A.51
! LOOP VARIABLE COLSF3A.52
& , K COLSF3A.53
! LOOP VARIABLE COLSF3A.54
& , J GSS2F402.224
! COLSF3A.55
! COLSF3A.56
! PASS THROUGH ALL THE COLUMNS COLLECTING LISTS OF POINTS WHICH COLSF3A.57
! HAVE THE SAME SURFACE TYPE. COLSF3A.58
DO K=1, NPD_SURFACE COLSF3A.59
N_POINT_TYPE(K)=0 COLSF3A.60
ENDDO COLSF3A.61
C GSS2F402.225
C GSS2F402.230
DO K=1,NPD_SURFACE GSS2F402.231
J=1 GSS2F402.232
DO L=1,N_PROFILE GSS2F402.233
IF (I_SURFACE(L).EQ.K) THEN GSS2F402.234
INDEX_SURFACE(J,K)=L GSS2F402.235
J=J+1 GSS2F402.236
N_POINT_TYPE(K)=N_POINT_TYPE(K)+1 GSS2F402.237
END IF GSS2F402.238
END DO GSS2F402.239
ENDDO COLSF3A.65
! COLSF3A.66
! COLSF3A.67
! COLSF3A.68
RETURN COLSF3A.69
END COLSF3A.70
*ENDIF DEF,A01_3A,OR,DEF,A02_3A COLSF3A.71
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.16