*IF DEF,A11_1A SETTRA1A.2
C ******************************COPYRIGHT****************************** GTS2F400.8731
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.8732
C GTS2F400.8733
C Use, duplication or disclosure of this code is subject to the GTS2F400.8734
C restrictions as set forth in the contract. GTS2F400.8735
C GTS2F400.8736
C Meteorological Office GTS2F400.8737
C London Road GTS2F400.8738
C BRACKNELL GTS2F400.8739
C Berkshire UK GTS2F400.8740
C RG12 2SZ GTS2F400.8741
C GTS2F400.8742
C If no contract has been raised with this copy of the code, the use, GTS2F400.8743
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.8744
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.8745
C Modelling at the above address. GTS2F400.8746
C ******************************COPYRIGHT****************************** GTS2F400.8747
C GTS2F400.8748
CLL SUBROUTINE SET_TRAC --------------------------------------------- SETTRA1A.3
CLL SETTRA1A.4
CLL PURPOSE: CALCULATES NUMBER OF EAST-WEST SWEEPS OF HORIZONTAL SETTRA1A.5
CLL ADVECTION REQUIRED ON EACH ROW TO MAINTAIN A CFL SETTRA1A.6
CLL NUMBER LESS THAN 0.5. SETTRA1A.7
CLL NOT SUITABLE FOR SINGLE COLUMN USE. SETTRA1A.8
CLL VERSION FOR CRAY Y-MP, CRAY T3E, and Workstations. ARB1F402.271
CLL SETTRA1A.10
CLL WRITTEN BY M.H. MAWSON SETTRA1A.11
CLL SETTRA1A.12
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: SETTRA1A.13
CLL VERSION DATE SETTRA1A.14
CLL 4.2 Oct. 96 T3E migration: *DEF CRAY removed (was used to GSS2F402.281
CLL switch on ISAMAX,ISAMIN - for PVP systems only). GSS2F402.282
CLL S.J.Swarbrick GSS2F402.283
CLL 4.2 15/08/96 MPP code added. Loop structure modified. RTHBarnes. ARB1F402.272
!LL 4.3 17/03/97 Remove print statement. RTHBarnes. ARB1F403.7
CLL SETTRA1A.15
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, SETTRA1A.16
CLL STANDARD B. SETTRA1A.17
CLL SETTRA1A.18
CLL SYSTEM COMPONENTS COVERED: P123 SETTRA1A.19
CLL SETTRA1A.20
CLL SYSTEM TASK: P1 SETTRA1A.21
CLL SETTRA1A.22
CLL DOCUMENTATION: U.M. Doc. Paper 11, by M.J.P. Cullen SETTRA1A.23
CLL SETTRA1A.24
CLLEND----------------------------------------------------------------- SETTRA1A.25
SETTRA1A.26
C SETTRA1A.27
C*L ARGUMENTS:------------------------------------------------------- SETTRA1A.28
SETTRA1A.29
SUBROUTINE SET_TRAC 1,2SETTRA1A.30
& (TRACER_EW_SWEEPS,U,P_FIELD,U_FIELD, SETTRA1A.31
& P_LEVELS,ROW_LENGTH, ARB1F402.273
*CALL ARGFLDPT 
ARB1F402.274
& LONGITUDE_STEP_INVERSE, ARB1F402.275
& SEC_P_LATITUDE,ADVECTION_TIMESTEP, SETTRA1A.33
& PSTAR,DELTA_AK,DELTA_BK,RS) SETTRA1A.34
SETTRA1A.35
IMPLICIT NONE SETTRA1A.36
SETTRA1A.37
INTEGER SETTRA1A.38
& P_FIELD !IN DIMENSION OF FIELDS ON PRESSURE GRID. SETTRA1A.39
&,U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID. SETTRA1A.40
&,ROW_LENGTH !IN NUMBER OF POINTS PER ROW. SETTRA1A.41
&,P_LEVELS !IN NUMBER OF PRESSURE LEVELS. SETTRA1A.42
! All TYPFLDPT arguments are intent IN ARB1F402.276
*CALL TYPFLDPT ARB1F402.277
*IF DEF,MPP ARB1F402.278
! Common blocks and parameters for MPP code ARB1F402.279
*CALL PARVARS ARB1F402.280
*ENDIF ARB1F402.281
SETTRA1A.43
INTEGER SETTRA1A.44
*IF DEF,MPP ARB1F402.282
& TRACER_EW_SWEEPS(glsize(2),P_LEVELS) ! OUT. ARB1F402.283
! Number of East-West sweeps required for each row (of global field) ARB1F402.284
*ELSE ARB1F402.285
& TRACER_EW_SWEEPS(P_FIELD/ROW_LENGTH,P_LEVELS) ! OUT. SETTRA1A.45
& ! Number of sweeps to be done in SETTRA1A.46
& ! East West calculation for each row. SETTRA1A.47
*ENDIF ARB1F402.286
SETTRA1A.48
REAL SETTRA1A.49
& U(U_FIELD,P_LEVELS) !IN ADVECTING U FIELD, MASS-WEIGHTED. SETTRA1A.50
&,SEC_P_LATITUDE(P_FIELD) !IN 1/COS(LAT) AT P POINTS SETTRA1A.51
&,RS(P_FIELD,P_LEVELS) !IN EFFECTIVE RADIUS OF EARTH SETTRA1A.52
SETTRA1A.53
REAL SETTRA1A.54
& LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) SETTRA1A.55
&,ADVECTION_TIMESTEP !IN SETTRA1A.56
&,PSTAR(P_FIELD) !IN SETTRA1A.57
&,DELTA_AK(P_LEVELS) !IN SETTRA1A.58
&,DELTA_BK(P_LEVELS) !IN SETTRA1A.59
SETTRA1A.60
C*--------------------------------------------------------------------- SETTRA1A.61
SETTRA1A.62
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- SETTRA1A.63
C DEFINE LOCAL ARRAYS: 4 ARE REQUIRED SETTRA1A.64
SETTRA1A.65
REAL SETTRA1A.66
& U_WORK(U_FIELD) SETTRA1A.67
&, COURANT_NUMBER(P_FIELD) SETTRA1A.68
&, PSTAR_UV(U_FIELD) SETTRA1A.69
&, RS_UV(U_FIELD) SETTRA1A.70
*IF DEF,MPP ARB1F402.287
INTEGER ARB1F402.288
& info ! Return code from GCom routines. ARB1F402.289
&,LOCAL_EW_SWEEPS(P_LEVELS,P_FIELD/ROW_LENGTH) ! for this PE ARB1F402.290
&,ALL_EW_SWEEPS(P_LEVELS,glsize(2)) ! to hold values from all PEs ARB1F402.291
! N.B. so that data are contiguous for inter-PE message passing routines ARB1F402.292
! GCG_IMAX & GC_IBCAST, these arrays are declared (levels,rows) ARB1F402.293
*ENDIF ARB1F402.294
C*--------------------------------------------------------------------- SETTRA1A.72
C DEFINE LOCAL VARIABLES SETTRA1A.73
INTEGER SETTRA1A.74
& I,J,K ! Do loop counters. SETTRA1A.75
&, I_START SETTRA1A.76
&, I_MAX SETTRA1A.77
&, P_ROWS SETTRA1A.78
*IF DEF,MPP ARB1F402.295
&, global_row ! row number in global array ALL_EW_SWEEPS ARB1F402.296
&, HALF_P_ROWS ! half of total no. of rows in global array ARB1F402.297
*ENDIF ARB1F402.298
SETTRA1A.79
REAL SETTRA1A.80
& MAX_COURANT SETTRA1A.81
SETTRA1A.82
C*L EXTERNAL SUBROUTINE CALLS:------------------------------------ SETTRA1A.83
SETTRA1A.84
EXTERNAL SETTRA1A.92
& P_TO_UV SETTRA1A.93
SETTRA1A.94
C*--------------------------------------------------------------------- SETTRA1A.95
SETTRA1A.96
CL MAXIMUM VECTOR LENGTH ASSUMED IS U_FIELD SETTRA1A.97
CL--------------------------------------------------------------------- SETTRA1A.98
CL INTERNAL STRUCTURE. SETTRA1A.99
CL--------------------------------------------------------------------- SETTRA1A.100
CL SETTRA1A.101
CL--------------------------------------------------------------------- SETTRA1A.102
CL SECTION 0. INITIALISATION SETTRA1A.103
CL--------------------------------------------------------------------- SETTRA1A.104
SETTRA1A.105
P_ROWS = P_FIELD/ROW_LENGTH SETTRA1A.106
*IF DEF,MPP ARB1F402.299
HALF_P_ROWS=glsize(2)/2 ! half total number of rows ARB1F402.300
*ENDIF ARB1F402.301
CL SETTRA1A.108
CL--------------------------------------------------------------------- SETTRA1A.109
CL SECTION 1. CALCULATE NUMBER OF SWEEPS REQUIRED ON EACH ROW. SETTRA1A.110
CL--------------------------------------------------------------------- SETTRA1A.111
SETTRA1A.112
CL Interpolate pressure field to velocity points. SETTRA1A.113
SETTRA1A.114
CALL P_TO_UV(PSTAR,PSTAR_UV,P_FIELD,U_FIELD,ROW_LENGTH,P_ROWS) SETTRA1A.115
SETTRA1A.116
CL Loop over all levels. SETTRA1A.117
SETTRA1A.118
DO K=1,P_LEVELS SETTRA1A.119
*IF DEF,MPP ARB1F402.302
! Initialise polar/North- & South-most rows. ARB1F402.303
ALL_EW_SWEEPS(K,1) = 1 ARB1F402.304
ALL_EW_SWEEPS(K,glsize(2)) = 1 ARB1F402.305
LOCAL_EW_SWEEPS(K,1) = 1 ARB1F402.306
LOCAL_EW_SWEEPS(K,P_ROWS) = 1 ARB1F402.307
IF (at_top_of_LPG) LOCAL_EW_SWEEPS(K,2) = 1 ARB1F402.308
IF (at_base_of_LPG) LOCAL_EW_SWEEPS(K,P_ROWS-1) = 1 ARB1F402.309
*ELSE ARB1F402.310
TRACER_EW_SWEEPS(1,K) = 1 SETTRA1A.120
TRACER_EW_SWEEPS(P_ROWS,K) = 1 SETTRA1A.121
*ENDIF ARB1F402.311
SETTRA1A.122
CL Interpolate RS field to velocity points. SETTRA1A.123
SETTRA1A.124
CALL P_TO_UV(RS(1,K),RS_UV,P_FIELD,U_FIELD,ROW_LENGTH,P_ROWS) SETTRA1A.125
SETTRA1A.126
CL Remove mass-weight from U. SETTRA1A.127
SETTRA1A.128
!!! DO I=1,U_FIELD ARB1F402.312
DO I = FIRST_VALID_PT,LAST_U_FLD_PT ARB1F402.313
U_WORK(I) = U(I,K)/ SETTRA1A.130
& (RS_UV(I)*(DELTA_AK(K)+DELTA_BK(K)*PSTAR_UV(I))) SETTRA1A.131
END DO SETTRA1A.132
SETTRA1A.133
CL Calculate Courant number on each interior P_ROW. SETTRA1A.134
SETTRA1A.135
!!! DO I=ROW_LENGTH+1,P_FIELD-ROW_LENGTH ARB1F402.314
DO I = START_POINT_NO_HALO,END_P_POINT_NO_HALO ARB1F402.315
COURANT_NUMBER(I) = .5*(U_WORK(I) + U_WORK(I-ROW_LENGTH)) SETTRA1A.137
& *ADVECTION_TIMESTEP*SEC_P_LATITUDE(I) SETTRA1A.138
& *LONGITUDE_STEP_INVERSE/RS(I,K) SETTRA1A.139
END DO SETTRA1A.140
SETTRA1A.141
CL Loop over all rows. SETTRA1A.142
SETTRA1A.143
!!! DO J=2,P_ROWS-1 ARB1F402.316
DO J = FIRST_ROW,P_LAST_ROW ARB1F402.317
CL Calculate maximum absolute courant number. SETTRA1A.145
SETTRA1A.146
*IF -DEF,MPP ARB1F402.318
I_START = (J-1)*ROW_LENGTH+1 SETTRA1A.147
I_MAX = I_START SETTRA1A.152
DO I=1,ROW_LENGTH-1 SETTRA1A.153
IF(ABS(COURANT_NUMBER(I+I_START)).GT. SETTRA1A.154
& ABS(COURANT_NUMBER(I_MAX))) I_MAX = I_START+I GSS2F402.284
END DO SETTRA1A.157
MAX_COURANT = ABS(COURANT_NUMBER(I_MAX)) SETTRA1A.158
*ELSE ARB1F402.319
MAX_COURANT = 0.0 ARB1F402.320
DO I = (J-1)*ROW_LENGTH+Offx+1,J*ROW_LENGTH-Offx ARB1F402.321
MAX_COURANT = MAX(ABS(COURANT_NUMBER(I)),MAX_COURANT) ARB1F402.322
END DO ARB1F402.323
*ENDIF ARB1F402.324
CL Set number of sweeps so that maximum courant number on each row SETTRA1A.160
Cl is less than 0.25 SETTRA1A.161
SETTRA1A.162
*IF -DEF,MPP ARB1F402.325
TRACER_EW_SWEEPS(J,K) = 1 + 4*MAX_COURANT SETTRA1A.163
*ELSE ARB1F402.326
LOCAL_EW_SWEEPS(K,J) = 1 + 4*MAX_COURANT ARB1F402.327
*ENDIF ARB1F402.328
SETTRA1A.164
CL End loop over rows. SETTRA1A.165
END DO SETTRA1A.166
CL End loop over levels. ARB1F402.329
END DO ARB1F402.330
SETTRA1A.167
*IF DEF,MPP ARB1F402.331
! Find max value of local_ew_sweeps for each row along all processors ARB1F402.332
! in group gc_proc_row_group ARB1F402.333
CALL GCG_IMAX((P_ROWS-2*Offy)*P_LEVELS,gc_proc_row_group,info, ARB1F402.334
& LOCAL_EW_SWEEPS(1,1+Offy)) ARB1F402.335
! Copy to correct place in global array all_ew_sweeps ARB1F402.336
DO J = FIRST_ROW,P_LAST_ROW ARB1F402.337
global_row = J+datastart(2)-Offy-1 ARB1F402.338
DO K = 1,P_LEVELS ARB1F402.339
ALL_EW_SWEEPS(K,global_row) = LOCAL_EW_SWEEPS(K,J) ARB1F402.340
END DO ARB1F402.341
END DO ARB1F402.342
! Broadcast section of global array from this processor to all others ARB1F402.343
! - only needs to be done by one processor per row. ARB1F402.344
DO I = 0,nproc-1,nproc_x ARB1F402.345
CALL GC_IBCAST(I,P_LEVELS*g_blsizep(2,I),I,nproc,info, ARB1F402.346
& ALL_EW_SWEEPS(1,g_datastart(2,I))) ARB1F402.347
END DO ARB1F402.348
*ENDIF ARB1F402.349
ARB1F402.350
CL Loop over all levels. ARB1F402.351
DO K=1,P_LEVELS ARB1F402.352
ARB1F402.353
CL Make number of sweeps in each hemisphere monotonic increasing SETTRA1A.168
Cl as you go towards the pole. SETTRA1A.169
*IF -DEF,MPP ARB1F402.354
DO J=P_ROWS/2,2,-1 SETTRA1A.171
IF(TRACER_EW_SWEEPS(J,K).LT.TRACER_EW_SWEEPS(J+1,K)) SETTRA1A.172
& TRACER_EW_SWEEPS(J,K) = TRACER_EW_SWEEPS(J+1,K) SETTRA1A.173
END DO SETTRA1A.174
SETTRA1A.175
DO J=P_ROWS/2+1,P_ROWS-1 SETTRA1A.176
IF(TRACER_EW_SWEEPS(J,K).LT.TRACER_EW_SWEEPS(J-1,K)) SETTRA1A.177
& TRACER_EW_SWEEPS(J,K) = TRACER_EW_SWEEPS(J-1,K) SETTRA1A.178
END DO SETTRA1A.179
*ELSE ARB1F402.355
DO J = HALF_P_ROWS,2,-1 ARB1F402.356
IF (ALL_EW_SWEEPS(K,J) .lt. ALL_EW_SWEEPS(K,J+1)) THEN ARB1F402.357
ALL_EW_SWEEPS(K,J) = ALL_EW_SWEEPS(K,J+1) ARB1F402.358
END IF ARB1F402.359
END DO ARB1F402.360
DO J = HALF_P_ROWS+1,glsize(2)-1 ARB1F402.361
IF (ALL_EW_SWEEPS(K,J) .lt. ALL_EW_SWEEPS(K,J-1)) THEN ARB1F402.362
ALL_EW_SWEEPS(K,J) = ALL_EW_SWEEPS(K,J-1) ARB1F402.363
END IF ARB1F402.364
END DO ARB1F402.365
! Initialise North- & South-most values ARB1F402.366
ALL_EW_SWEEPS(K,1) = 1 ARB1F402.367
ALL_EW_SWEEPS(K,glsize(2)) = 1 ARB1F402.368
! Copy from local global array all_ew_sweeps to array tracer_ew_sweeps ARB1F402.369
! that will be passed to TRAC_ADV. ARB1F402.370
DO J = 1,glsize(2) ARB1F402.371
TRACER_EW_SWEEPS(J,K) = ALL_EW_SWEEPS(K,J) ARB1F402.372
END DO ARB1F402.373
*ENDIF ARB1F402.376
SETTRA1A.180
CL End loop over levels. SETTRA1A.181
END DO SETTRA1A.182
SETTRA1A.183
CL END OF ROUTINE SET_TRAC SETTRA1A.184
SETTRA1A.185
RETURN SETTRA1A.186
END SETTRA1A.187
*ENDIF SETTRA1A.188