*IF DEF,C93_1A,OR,DEF,C93_2A GNF0F402.20
C ******************************COPYRIGHT****************************** GTS2F400.8533
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.8534
C GTS2F400.8535
C Use, duplication or disclosure of this code is subject to the GTS2F400.8536
C restrictions as set forth in the contract. GTS2F400.8537
C GTS2F400.8538
C Meteorological Office GTS2F400.8539
C London Road GTS2F400.8540
C BRACKNELL GTS2F400.8541
C Berkshire UK GTS2F400.8542
C RG12 2SZ GTS2F400.8543
C GTS2F400.8544
C If no contract has been raised with this copy of the code, the use, GTS2F400.8545
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.8546
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.8547
C Modelling at the above address. GTS2F400.8548
C ******************************COPYRIGHT****************************** GTS2F400.8549
C GTS2F400.8550
CLL SUBROUTINE SETFILT ------------------------------------------ SETF1A.3
CLL SETF1A.4
CLL PURPOSE: SETF1A.5
CLL SUBROUTINE 'SETFILT' - COMPUTES FACTORS OF N & TRIGONOMETRIC SETF1A.6
CLL FUNCTIONS REQUIRED BY FOURIER, FFT99 & FFT991 SETF1A.7
CLL UNIFIED MODEL RE-WRITE OF ECMWF ROUTINE SET99 SETF1A.8
CLL ALSO CALCULATES TWO_D_GRID_CORRECTION FACTORS USED IN SET_FIL SETF1A.9
CLL SETF1A.10
CLL NOT SUITABLE FOR SINGLE COLUMN USE. SETF1A.11
CLL SETF1A.12
CLL REWRITTEN TO UNIFIED MODEL PROGRAMMING STANDARDS FROM ECMWF SETF1A.13
CLL CODE BY M.H.MAWSON; ORIGINAL CODE WRITER C. TEMPERTON SETF1A.14
CLL SETF1A.15
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: SETF1A.16
CLL 3.1 24/02/93 Tidy code to remove QA Fortran messages. MM240293.4
! 4.1 19/06/95 Added MPP code and argument ROWS P.Burton APB7F401.669
CLL vn4.2 07/11/96:Allow this routine to be used in C93_2A (Farnon) GNF0F402.19
CLL SETF1A.18
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, SETF1A.19
CLL STANDARD B. VERSION 2, DATED 18/01/90 SETF1A.20
CLL SYSTEM TASK: P1 SETF1A.21
CLL SETF1A.22
CLL DOCUMENTATION: UNIFIED MODEL DOCUMENTATION PAPER NUMBER 10 SETF1A.23
CLL M.J.P. CULLEN, T. DAVIES AND M.H. MAWSON SETF1A.24
CLL VERSION 8 DATED 1/05/90. SETF1A.25
CLLEND------------------------------------------------------------- SETF1A.26
SETF1A.27
C*L ARGUMENT LIST SETF1A.28
SETF1A.29
SUBROUTINE SETFILT(TRIGS,IFAX,N,ROWS,TWO_D_GRID_CORRECTION, 2APB7F401.670
& P_FIELD, COS_P_LATITUDE) APB7F401.671
SETF1A.32
IMPLICIT NONE SETF1A.33
SETF1A.34
INTEGER SETF1A.35
* IFAX(10) !OUT HOLDS FACTORS OF N SETF1A.36
SETF1A.37
INTEGER SETF1A.38
* N !IN NUMBER OF POINTS OF DATA ON A SLICE SETF1A.39
*, ROWS !IN NUMBER OF ROWS IN P_FIELD APB7F401.672
*, P_FIELD !IN HOLDS NUMBER OF POINTS IN THE FIELD. SETF1A.40
SETF1A.41
REAL SETF1A.42
* COS_P_LATITUDE(P_FIELD) !IN COSINE OF LATITUDE AT P POINTS. SETF1A.43
SETF1A.44
REAL SETF1A.45
* TRIGS(N) !OUT HOLDS TRIGONOMETRIC FUNCTIONS NEEDED BY SETF1A.46
* ! FOURIER, FFT99 AND FFT991 SETF1A.47
*, TWO_D_GRID_CORRECTION(ROWS) !OUT HOLDS FACTOR ON APB7F401.673
* ! EACH ROW WHICH MODIFIES THE STABILITY SETF1A.49
* ! RELATION EQUATION (50) SO THAT IT TAKES INTO SETF1A.50
* ! ACCOUNT THE 2-D NATURE OF THE GRID. SETF1A.51
C* -------------------------------------------------------------- SETF1A.52
*IF DEF,MPP APB7F401.674
*CALL PARVARS 
APB7F401.675
*CALL PARFFTS APB7F401.676
*ENDIF APB7F401.677
SETF1A.53
C*L WORKSPACE. 2 ARRAYS ARE REQUIRED ---------------------------- SETF1A.54
INTEGER SETF1A.55
* JFAX(10) ! HOLDS FACTORS OF N BEFORE THEY ARE ORDERED SETF1A.56
* ! AND STORED IN IFAX SETF1A.57
* ,LFAX(8) ! HOLDS LIST OF VALID FACTORS. LAST VALUE IS SETF1A.58
* ! MINUS PENULTIMATE ONE. THIS IS USED TO SETF1A.59
* ! SEND CODE TO THE ERROR MESSAGE AS N CONTAINS SETF1A.60
* ! AN INVALID FACTOR. SETF1A.61
C* -------------------------------------------------------------- SETF1A.62
SETF1A.63
C*L NO EXTERNAL ROUTINES --------------------------------------- SETF1A.64
C* --------------------------------------------------------------- SETF1A.65
SETF1A.66
C LOCAL VARIABLES SETF1A.67
REAL SETF1A.68
* DEL ! HOLDS ANGLE IN RADIANS BETWEEN POINTS ON LATITUDE SETF1A.69
* ! CIRCLE SETF1A.70
* ,ANGLE ! HOLDS ANGLE IN RADIANS AT A POINT ON THE LATITUDE SETF1A.71
* ! CIRCLE SETF1A.72
SETF1A.73
INTEGER SETF1A.74
* K ! LOOP COUNTER SETF1A.75
* ,I ! LOOP COUNTER SETF1A.76
* ,NU ! HOLDS CURRENT FACTORISED VALUE OF N SETF1A.77
* ,IFAC ! HOLDS CURRENT FACTOR BEING TESTED FOR SETF1A.78
* ,L ! HOLDS CURRENT POSITION IN LFAX ARRAY SETF1A.79
* ,NFAX ! HOLDS TOTAL NUMBER OF FACTORS OF N SETF1A.80
SETF1A.82
CL SETF1A.83
CL ---------------------------------------------------------------- SETF1A.84
CL SECTION 1. INITIALISATION. SETF1A.85
CL ---------------------------------------------------------------- SETF1A.86
SETF1A.87
LFAX(1)=6 SETF1A.89
LFAX(2)=8 SETF1A.90
LFAX(3)=5 SETF1A.91
LFAX(4)=4 SETF1A.92
LFAX(5)=3 SETF1A.93
LFAX(6)=2 SETF1A.94
LFAX(7)=1 SETF1A.95
LFAX(8)=-1 SETF1A.96
SETF1A.97
CL SETF1A.98
CL ---------------------------------------------------------------- SETF1A.99
CL SECTION 2. SET TRIGONOMETRIC FUNCTIONS SETF1A.100
CL ---------------------------------------------------------------- SETF1A.101
SETF1A.102
DEL=4.0*ASIN(1.0)/N MM240293.5
DO 200 K=0,N/2-1 SETF1A.104
ANGLE=K*DEL MM240293.6
*IF -DEF,MPP APB7F401.678
TRIGS(2*K+1)=COS(ANGLE) SETF1A.106
TRIGS(2*K+2)=SIN(ANGLE) SETF1A.107
*ELSE APB7F401.679
! Set global_trigs array - carried by COMMON info FILTER APB7F401.680
global_trigs(2*K+1)=COS(ANGLE) APB7F401.681
global_trigs(2*K+2)=SIN(ANGLE) APB7F401.682
*ENDIF APB7F401.683
200 CONTINUE SETF1A.108
SETF1A.109
CL SETF1A.110
CL ---------------------------------------------------------------- SETF1A.111
CL SECTION 3. FIND FACTORS OF N (8,6,5,4,3,2; ONLY ONE 8 ALLOWED) SETF1A.112
CL STORE FACTORS IN DESCENDING ORDER. SETF1A.113
CL ---------------------------------------------------------------- SETF1A.114
SETF1A.115
C LOOK FOR SIXES FIRST AND STORE FACTORS IN DESCENDING ORDER SETF1A.116
NU=N SETF1A.117
IFAC=6 SETF1A.118
C K HOLDS NUMBER OF FACTORS FOUND. L IS USED TO MOVE THROUGH LIST OF SETF1A.119
C VALID FACTORS. SETF1A.120
K=0 SETF1A.121
L=1 SETF1A.122
300 CONTINUE SETF1A.123
IF (MOD(NU,IFAC).EQ.0) THEN SETF1A.124
C IF IFAC IS A FACTOR OF N. SETF1A.125
K=K+1 SETF1A.126
JFAX(K)=IFAC SETF1A.127
IF (IFAC.EQ.8.AND.K.NE.1) THEN SETF1A.128
JFAX(1)=8 SETF1A.129
JFAX(K)=6 SETF1A.130
ENDIF SETF1A.131
NU=NU/IFAC SETF1A.132
C IF N FACTORISES COMPLETELY JUMP PAST ERROR MESSAGE SETF1A.133
IF(NU.EQ.1) GO TO 310 SETF1A.134
C IF FACTOR IS NOT AN 8 SEE IF IT APPEARS MORE THAN ONCE. SETF1A.135
IF(IFAC.NE.8) GO TO 300 SETF1A.136
ENDIF SETF1A.137
L=L+1 SETF1A.138
IFAC=LFAX(L) SETF1A.139
C IF NOT COMPLETELY FACTORISED GO BACK TO TOP OF PROCEDURE SETF1A.140
IF(IFAC.GT.1) GO TO 300 SETF1A.141
SETF1A.142
C ILLEGAL FACTOR IN N. PRINT ERROR MESSAGE THEN JUMP TO END OF SETF1A.143
C ROUTINE. SETF1A.144
SETF1A.145
WRITE(6,1300) N SETF1A.146
1300 FORMAT(' ERROR IN SETFILT. N = ',I4,' CONTAINS AN ILLEGAL FACTOR') SETF1A.147
GO TO 330 SETF1A.148
SETF1A.149
C NOW REVERSE ORDER OF FACTORS SO THAT THEY ARE IN ASCENDING ORDER SETF1A.150
SETF1A.151
310 CONTINUE SETF1A.152
NFAX=K SETF1A.153
IFAX(1)=NFAX SETF1A.154
DO 320 I=1,NFAX SETF1A.155
IFAX(NFAX+2-I)=JFAX(I) SETF1A.156
320 CONTINUE SETF1A.157
IFAX(10)=N SETF1A.158
330 CONTINUE SETF1A.159
SETF1A.160
CL SETF1A.161
CL ---------------------------------------------------------------- SETF1A.162
CL SECTION 4. CALCULATE 2-D GRID CORRECTION TERM. SETF1A.163
CL SEE DOC. PAPER 10 SECTION 3.5. SETF1A.164
CL ---------------------------------------------------------------- SETF1A.165
SETF1A.166
CL CALCULATION NOT PERFORMED ON POLAR ROWS. SETF1A.167
*IF -DEF,MPP APB7F401.684
TWO_D_GRID_CORRECTION(1) = 0. SETF1A.168
TWO_D_GRID_CORRECTION(ROWS) = 0. SETF1A.169
DO 400 I=2,ROWS-1 SETF1A.170
TWO_D_GRID_CORRECTION(I) = (1.+4.*(ROWS-1.)*(ROWS-1.)/(N*N) SETF1A.171
* *COS_P_LATITUDE(I*N) SETF1A.172
* *COS_P_LATITUDE(I*N))**.5 SETF1A.173
400 CONTINUE SETF1A.174
*ELSE APB7F401.685
DO I=1+Offy,ROWS-Offy APB7F401.686
TWO_D_GRID_CORRECTION(I) = APB7F401.687
& (1.+4.*(glsize(2)-1.)*(glsize(2)-1.)/(glsize(1)*glsize(1))* APB7F401.688
& COS_P_LATITUDE(I*lasize(1))*COS_P_LATITUDE(I*lasize(1)))**0.5 APB7F401.689
ENDDO APB7F401.690
APB7F401.691
IF (attop) TWO_D_GRID_CORRECTION(1+Offy)=0.0 APB7F401.692
IF (atbase) TWO_D_GRID_CORRECTION(ROWS-Offy)=0.0 APB7F401.693
*ENDIF APB7F401.694
SETF1A.175
CL END OF ROUTINE SETFILT SETF1A.176
RETURN SETF1A.177
END SETF1A.178
*ENDIF SETF1A.179