SUBROUTINE ABCALC (MODE_L,MODE_H,MODE_C,LEVELS,ETA_P,ETA_S,ETAH 4ABCALC1.6
& ,AK,BK,AKH,BKH,IERR) ABCALC1.7
ABCALC1.8
IMPLICIT NONE ABCALC1.9
! ABCALC1.10
! Description: ABCALC1.11
! Calculates a set of A and B values to define a ABCALC1.12
! set of hybrid model levels from ETA half levels. ABCALC1.13
! Original code written for user interface by ABCALC1.14
! Richard Swinbank 15/06/90. ABCALC1.15
! ABCALC1.16
! Method: ABCALC1.17
! <Say how it does it: include references to external documentation> ABCALC1.18
! <If this routine is very complex, then include a "pseudo code" ABCALC1.19
! description of it to make its structure and method clear> ABCALC1.20
! ABCALC1.21
! Current Code Owner: D.M. Goddard ABCALC1.22
! ABCALC1.23
! History: ABCALC1.24
! Version Date Comment ABCALC1.25
! ------- ---- ------- ABCALC1.26
! 3.5 24/02/95 Original code. (D.M. Goddard) ABCALC1.27
! ABCALC1.28
! Code Description: ABCALC1.29
! Language: FORTRAN 77 + common extensions. ABCALC1.30
! This code is written to UMDP3 v7 programming standards. ABCALC1.31
! ABCALC1.32
! System component covered: None ABCALC1.33
! System Task: None ABCALC1.34
! ABCALC1.35
! Declarations: ABCALC1.36
! These are of the form:- ABCALC1.37
! INTEGER ExampleVariable !Description of variable ABCALC1.38
! ABCALC1.39
! Global variables (*CALLed COMDECKs etc...): ABCALC1.40
*CALL C_R_CP 
ABCALC1.41
ABCALC1.42
! Subroutine arguments ABCALC1.43
! Scalar arguments with intent(in): ABCALC1.44
INTEGER MODE_L ! Method of calculation of ABCALC1.45
! eta level (ETAK) ABCALC1.46
! from layers (ETAKH) ABCALC1.47
! 1 - LOGARTHMIC MEAN ABCALC1.48
! 2 - OLD MET O 20 METHOD ABCALC1.49
! 3 - ARITHMETIC MEAN ABCALC1.50
! 4 - arithmetic mean of half ABCALC1.51
! level exner ABCALC1.52
! 5 - pressure weighted mean of ABCALC1.53
! half level exner ABCALC1.54
ABCALC1.55
INTEGER MODE_H ! Method of calculating AKH and ABCALC1.56
! BKH from ETAKH, ETA_S and ABCALC1.57
! ETA_P ABCALC1.58
! 1 - Cubic variation of A, B ABCALC1.59
! with ETA ABCALC1.60
ABCALC1.61
INTEGER MODE_C ! Method of calculating AK and ABCALC1.62
! BK from AKH, BKH AND ETAK ABCALC1.63
! 1 - Linear interpolation ABCALC1.64
! 2 - Half-height method ABCALC1.65
ABCALC1.66
INTEGER LEVELS ! Number of levels ABCALC1.67
ABCALC1.68
REAL ETA_S ! Eta values at which levels ABCALC1.69
!become sigma surf ABCALC1.70
ABCALC1.71
REAL ETA_P ! Eta values at which levels ABCALC1.72
! become P surfaces ABCALC1.73
ABCALC1.74
! Array arguments with intent(in): ABCALC1.75
REAL ETAH(LEVELS+1) ! Eta values at model layer ABCALC1.76
! boundaries ETAKH ABCALC1.77
ABCALC1.78
! Scalar arguments with intent(out): ABCALC1.79
INTEGER IERR ! Error code (>0 if error) ABCALC1.80
ABCALC1.81
! Array arguments with intent(out): ABCALC1.82
REAL AK(LEVELS) ! Value to define hybrid levels ABCALC1.83
REAL BK(LEVELS) ! Value to define hybrid levels ABCALC1.84
REAL AKH(LEVELS+1) ! Value to defn layer boundaries ABCALC1.85
REAL BKH(LEVELS+1) ! Value to defn layer boundaries ABCALC1.86
ABCALC1.87
! Local parameters: ABCALC1.88
INTEGER ILEVP ! Maximum number of levels ABCALC1.89
INTEGER ILEVP1 ! Maximum number of half levels ABCALC1.90
REAL TINY ! Smallest allowed A value ABCALC1.91
PARAMETER (ILEVP=75, ILEVP1=76) ABCALC1.92
PARAMETER (TINY=1.0E-8) ABCALC1.93
ABCALC1.94
! Local scalars: ABCALC1.95
INTEGER JL ! Loop index ABCALC1.96
REAL Z !! ABCALC1.97
REAL Z1 !! Working parameters used to ABCALC1.98
REAL Z2 !!calculate ETAL ABCALC1.99
ABCALC1.100
! Local dynamic arrays: ABCALC1.101
REAL AH(ILEVP1) ! Hybrid coordinate parameter ABCALC1.102
REAL AL(ILEVP) ! A values on model levels ABCALC1.103
REAL ETAD(ILEVP) ! Thickness of model layers ABCALC1.104
REAL ETAL(ILEVP) ! Eta values on model levels ABCALC1.105
ABCALC1.106
!- End of header ABCALC1.107
ABCALC1.108
ABCALC1.109
C------------------------------------------------------------------- ABCALC1.110
C 1 initialisation ABCALC1.111
C------------------------------------------------------------------- ABCALC1.112
ABCALC1.113
ABCALC1.114
IF(LEVELS.GT.ILEVP) THEN ABCALC1.115
WRITE(6,'('' NO. LEVELS ('',I3,'') > MAXIMUM ('',I3,'')'')') ABCALC1.116
& LEVELS,ILEVP ABCALC1.117
IERR=1 ABCALC1.118
RETURN ABCALC1.119
END IF ABCALC1.120
IF(ETA_S.LT.ETA_P) THEN ABCALC1.121
WRITE(6,'('' ETA_S < ETA_P '',2F12.8)') ETA_S,ETA_P ABCALC1.122
IERR=2 ABCALC1.123
RETURN ABCALC1.124
ELSE ABCALC1.125
IERR=0 ABCALC1.126
END IF ABCALC1.127
ABCALC1.128
C------------------------------------------------------------------- ABCALC1.129
C 2 Calculate derived values ABCALC1.130
C------------------------------------------------------------------- ABCALC1.131
ABCALC1.132
C Calculate layer thickness ABCALC1.133
DO JL=1,LEVELS ABCALC1.134
ETAD(JL)=ETAH(JL)-ETAH(JL+1) ABCALC1.135
END DO ABCALC1.136
ABCALC1.137
C Calculate (Layer centre) value of ETA ABCALC1.138
IF(MODE_L.EQ.1) THEN ABCALC1.139
DO JL=1,LEVELS ABCALC1.140
IF(ETAH(JL+1).LE.0.0) THEN ABCALC1.141
ETAL(JL)=ETAH(JL)*EXP(-1.0) ABCALC1.142
ELSE ABCALC1.143
ETAL(JL)=SQRT(ETAH(JL)*ETAH(JL+1)) ABCALC1.144
END IF ABCALC1.145
END DO ABCALC1.146
ELSE IF(MODE_L.EQ.2) THEN ABCALC1.147
DO JL=1,LEVELS ABCALC1.148
IF(ETAH(JL+1).LE.0.0) THEN ABCALC1.149
ETAL(JL)=ETAH(JL)*EXP(-1.0) ABCALC1.150
ELSE ABCALC1.151
ETAL(JL)=(ETAH(JL)-ETAH(JL+1))/LOG(ETAH(JL)/ETAH(JL+1)) ABCALC1.152
END IF ABCALC1.153
END DO ABCALC1.154
ELSE IF(MODE_L.EQ.3) THEN ABCALC1.155
DO JL=1,LEVELS ABCALC1.156
ETAL(JL) = 0.5 * (ETAH(JL) + ETAH(JL+1)) ABCALC1.157
END DO ABCALC1.158
ELSE IF(MODE_L.EQ.4) THEN ABCALC1.159
C Method 4 - unified model - pre vn2.6 ABCALC1.160
DO JL=1,LEVELS ABCALC1.161
Z1=ETAH(JL)**KAPPA ABCALC1.162
Z2=ETAH(JL+1)**KAPPA ABCALC1.163
Z=0.5*(Z1+Z2) ABCALC1.164
ETAL(JL) = Z**(1.0/KAPPA) ABCALC1.165
END DO ABCALC1.166
ELSE IF(MODE_L.EQ.5) THEN ABCALC1.167
C Method 5 - unified model - vn2.6 onwards ABCALC1.168
DO JL=1,LEVELS ABCALC1.169
Z1=ETAH(JL)**(KAPPA + 1.0) ABCALC1.170
Z2=ETAH(JL+1)**(KAPPA + 1.0) ABCALC1.171
Z=(Z2-Z1)/(( ETAH(JL+1) - ETAH(JL) )*(KAPPA + 1.0) ) ABCALC1.172
ETAL(JL) = Z**(1.0/KAPPA) ABCALC1.173
END DO ABCALC1.174
END IF ABCALC1.175
ABCALC1.176
C Calculate hybrid coordinate parameter A ABCALC1.177
Z1=(ETA_S-ETA_P)*(ETA_S-ETA_P)*(ETA_S-ETA_P) ABCALC1.178
DO JL=1,LEVELS+1 ABCALC1.179
IF(ETAH(JL).GE.ETA_S) THEN ABCALC1.180
AH(JL)=0.0 ABCALC1.181
ELSE IF(ETAH(JL).LE.ETA_P) THEN ABCALC1.182
AH(JL)=ETAH(JL) ABCALC1.183
ELSE ABCALC1.184
Z2=ETAH(JL)*(ETA_S+ETA_P)-2.0*ETA_P*ETA_P ABCALC1.185
AH(JL)=(ETA_S-ETAH(JL))*(ETA_S-ETAH(JL))*Z2/Z1 ABCALC1.186
IF(ABS(AH(JL)).LT.TINY) AH(JL)=0.0 ABCALC1.187
END IF ABCALC1.188
END DO ABCALC1.189
ABCALC1.190
C Calculate A values at LEVELS ABCALC1.191
IF(MODE_C.EQ.1) THEN ABCALC1.192
DO JL=1,LEVELS ABCALC1.193
AL(JL)=AH(JL)+(AH(JL+1)-AH(JL))* ABCALC1.194
& (ETAL(JL)-ETAH(JL))/(ETAH(JL+1)-ETAH(JL)) ABCALC1.195
IF(ABS(AL(JL)).LT.TINY) AL(JL)=0.0 ABCALC1.196
END DO ABCALC1.197
ELSE IF(MODE_C.EQ.2) THEN ABCALC1.198
DO JL=1,LEVELS ABCALC1.199
Z1=(ETAH(JL )-AH(JL )) * ETAH(JL )**(KAPPA-1.0) ABCALC1.200
Z2=(ETAH(JL+1)-AH(JL+1)) * ETAH(JL+1)**(KAPPA-1.0) ABCALC1.201
Z=(0.5*(Z1+Z2)) * ETAL(JL)**(-(KAPPA-1.0)) ABCALC1.202
AL(JL)=ETAL(JL)-Z ABCALC1.203
IF(ABS(AL(JL)).LT.TINY) AL(JL)=0.0 ABCALC1.204
END DO ABCALC1.205
END IF ABCALC1.206
ABCALC1.207
C Set A and B Arrays ABCALC1.208
DO JL=1,LEVELS ABCALC1.209
AK(JL)=PREF*AL(JL) ABCALC1.210
BK(JL)=ETAL(JL)-AL(JL) ABCALC1.211
IF(ABS(BK(JL)).LT.TINY) BK(JL)=0.0 ABCALC1.212
END DO ABCALC1.213
DO JL=1,LEVELS+1 ABCALC1.214
AKH(JL)=PREF*AH(JL) ABCALC1.215
BKH(JL)=ETAH(JL)-AH(JL) ABCALC1.216
IF(ABS(BKH(JL)).LT.TINY) BKH(JL)=0.0 ABCALC1.217
END DO ABCALC1.218
ABCALC1.219
RETURN ABCALC1.220
END ABCALC1.221
*ENDIF ABCALC1.222