Skip to content

Commit 97051a0

Browse files
jacobwilliamsjacobwilliams
committed
some cleanups in legacy validation code
1 parent f7c1537 commit 97051a0

1 file changed

Lines changed: 61 additions & 90 deletions

File tree

‎test/roberts.f90‎

Lines changed: 61 additions & 90 deletions
Original file line numberDiff line numberDiff line change
@@ -118,10 +118,9 @@ SUBROUTINE rdymos(Sa,Su,Rjud,Dafr,Gsti,Te,Ad,Wmol,Rhod)
118118
!
119119
IMPLICIT NONE
120120

121-
real(dp) Ad , dafl , Dafr , Gsti , outr , Rhod , rjfl , Rjud , Sa , sd , sf , Su , tauo , Te , Wmol
122-
INTEGER int , nd
123-
DIMENSION Sa(3) , Su(2) , Te(2) , Ad(6)
124-
DIMENSION sf(3) , sd(15)
121+
real(dp) :: Ad(6) , dafl , Dafr , Gsti , outr , Rhod , rjfl , Rjud , &
122+
Sa(3) , sd(15) , sf(3) , Su(2) , tauo , Te(2) , Wmol
123+
INTEGER :: int , nd
125124
!
126125
!------
127126
!
@@ -138,9 +137,9 @@ SUBROUTINE rdymos(Sa,Su,Rjud,Dafr,Gsti,Te,Ad,Wmol,Rhod)
138137

139138
CALL soflud(rjfl,dafl,sd,outr)
140139

141-
IF ( outr/=0. ) THEN
140+
IF ( outr/=0.0_dp ) THEN
142141
WRITE (6,*) ' ERROR IN ROUTINE JDYMOS: OUTR = ' , int(outr)
143-
STOP
142+
error stop
144143
ENDIF
145144

146145
tauo = 6.696_dp
@@ -214,11 +213,9 @@ SUBROUTINE rsmods(Altu,Rjud,Dafr,Te,Al,Wmol,Rhod)
214213
!
215214
IMPLICIT NONE
216215

217-
real(dp) Al , Altu , Dafr , outr , Rhod , &
218-
Rjud , sd , sf , Te , vari , Wmol
219-
INTEGER int
220-
DIMENSION Te(2) , Al(6)
221-
DIMENSION sf(3) , sd(15)
216+
real(dp) :: Al(6) , Altu , Dafr , outr , Rhod , &
217+
Rjud , sd(15) , sf(3) , Te(2) , vari , Wmol
218+
INTEGER :: int
222219
!
223220
!------
224221
!
@@ -325,14 +322,8 @@ SUBROUTINE rsdamo(Sa,Su,Sf,Rjud,Dafr,Gsti,Te,Ad,Wmol,Rhod)
325322
!
326323
IMPLICIT NONE
327324

328-
real(dp) Ad , al , amjd , Dafr , Gsti , Rhod , Rjud , Sa , Sf , Su , Te , Wmol
329-
330-
DIMENSION Sa(3) , Su(2) , Sf(3) , Te(2) , Ad(6)
331-
DIMENSION al(6)
332-
333-
!
334-
!------
335-
!
325+
real(dp) :: Ad(6) , al(6) , amjd , Dafr , Gsti , Rhod , &
326+
Rjud , Sa(3) , Sf(3) , Su(2) , Te(2) , Wmol
336327

337328
amjd = Rjud + 33282.0_dp + Dafr/86400.0_dp
338329

@@ -604,25 +595,25 @@ SUBROUTINE dyjrmo(Djm,Sun,Sat,Geo,Temp,Dn,Amw,Dens)
604595
! 377,1971
605596
!
606597
! AUTHOR : HELIO KOITI KUGA - JUNE 1985 -INPE-DMC/DDO
607-
!
608-
! DIMENSION ARRAY'S, VARIABLES AND CONSTANTS
609-
!
598+
610599
IMPLICIT NONE
611600

612-
real(dp) abs , Amw , capphi , cos , d1 , d2 , d3 , d4 , d5 , d6 , Dens , df , Djm , dlhe , dlr , dlr20 , dlrgm , dlrsa , &
613-
dlrsl
614-
real(dp) Dn , dtg , dtg18 , dtg20 , eta , expkp , f , fdfz , fs , fsm , gdft , Geo , h , pk , s , Sat
615-
real(dp) sat1 , sat2 , sat3 , sign , sin , sumn , sumnm , Sun , sun1 , sun2 , tanh , tau , Temp , theta , tinf , tsubc , tsubl , &
616-
tz
617-
INTEGER mod
618-
DIMENSION Sun(2) , Sat(3) , Geo(3) , Temp(2) , Dn(6)
601+
real(dp) :: abs , Amw , capphi , cos , d1 , d2 , d3 , d4 , d5 , d6 , Dens , df , &
602+
Djm , dlhe , dlr , dlr20 , dlrgm , dlrsa , dlrsl , Dn(6) , dtg , dtg18 , &
603+
dtg20 , eta , expkp , f , fdfz , fs , fsm , gdft , Geo(3) , h , pk , s , Sat(3) , &
604+
sat1 , sat2 , sat3 , sign , sin , sumn , sumnm , Sun(2) , sun1 , sun2 , tanh , &
605+
tau , Temp(2) , theta , tinf , tsubc , tsubl , tz
619606

620607
real(dp),parameter :: pi = acos(-1.0_dp)
621608
real(dp),parameter :: piv2 = 2.0_dp * pi
622609
real(dp),parameter :: piv4 = 4.0_dp * pi
623610
real(dp),parameter :: pid4 = pi / 4.0_dp
624611
real(dp),parameter :: cons25 = sin(pid4)**3
625-
!
612+
real(dp),parameter :: RAD_PER_DEG = pi / 180.0_dp !! degree to radian conversion factor
613+
real(dp),parameter :: d37 = 37.0_dp * RAD_PER_DEG !! 37 degrees in radians
614+
real(dp),parameter :: d06 = 6.0_dp * RAD_PER_DEG !! 6 degrees in radians
615+
real(dp),parameter :: d43 = 43.0_dp * RAD_PER_DEG !! 43 degrees in radians
616+
626617
sun1 = Sun(1)
627618
sun2 = Sun(2)
628619
sat1 = Sat(1)
@@ -647,7 +638,8 @@ SUBROUTINE dyjrmo(Djm,Sun,Sat,Geo,Temp,Dn,Amw,Dens)
647638
! EQUATION 16J
648639
!
649640
h = sat1 - sun1
650-
tau = h - 0.64577182_dp + 0.10471976_dp*sin(h+0.75049158_dp)
641+
! tau = h - 0.64577182_dp + 0.10471976_dp*sin(h+0.75049158_dp)
642+
tau = h - d37 + d06 * sin(h + d43)
651643
!
652644
! EXOSPHERIC TEMPERATURE TSUBL WITHOUT CORRECTION
653645
! FOR GEOMAGNETIC ACTIVITY
@@ -763,8 +755,7 @@ SUBROUTINE stjrmo(Tinf,Sat3,Tz,Dn)
763755
!
764756
IMPLICIT NONE
765757

766-
real(dp) Dn , Sat3 , Tinf , Tz
767-
DIMENSION Dn(6)
758+
real(dp) :: Dn(6) , Sat3 , Tinf , Tz
768759

769760
IF ( Sat3>125.0_dp ) THEN
770761
!
@@ -816,16 +807,15 @@ SUBROUTINE stjr01(Tinf,Sat3,Tl2,Al10n)
816807
!
817808
IMPLICIT NONE
818809

819-
real(dp) ain , al , Al10n , am1 , am2 , an , anm , dens , dz , dzx , exp , fact1 , fact2 , gx , gz , Sat3 , sum1 , &
820-
sum2
821-
real(dp) Tinf , tl1 , Tl2 , tx , z , zd , zend , zr
822-
INTEGER i , int , j , n
823-
DIMENSION Al10n(6)
810+
real(dp) :: ain , al , Al10n(6) , am1 , am2 , an , anm , dens , dz , dzx , &
811+
exp , fact1 , fact2 , gx , gz , Sat3 , sum1 , &
812+
sum2 , Tinf , tl1 , Tl2 , tx , z , zd , zend , zr
813+
INTEGER :: i , int , j , n
824814

825815
real(dp),parameter :: ra = 6356.766_dp !! POLAR EARTH RADIUS (KM)
826816
real(dp),dimension(5),parameter :: wt = 2.0_dp/45.0_dp*[7.0_dp,32.0_dp,12.0_dp,32.0_dp,7.0_dp] !! WEIGHTS FOR THE NEWTON-COTES FIVE POINT QUADRATURE FORMULAE
827817
!
828-
tx = 371.668_dp + 0.0518806_dp*Tinf - 294.3503_dp*exp(-0.00216222_dp*Tinf)
818+
tx = 371.6678_dp + 0.0518806_dp*Tinf - 294.3503_dp*exp(-0.00216222_dp*Tinf)
829819
gx = 0.054285714_dp*(tx-183.0_dp)
830820
al = log(Sat3/90.0_dp)
831821
n = int(al/0.050_dp) + 1
@@ -840,7 +830,7 @@ SUBROUTINE stjr01(Tinf,Sat3,Tl2,Al10n)
840830
z = zend
841831
zend = zr*z
842832
dz = 0.25_dp*(zend-z)
843-
sum1 = 0.31111111_dp*ain
833+
sum1 = wt(1)*ain
844834
DO j = 2 , 5
845835
z = z + dz
846836
!
@@ -915,22 +905,18 @@ SUBROUTINE stjr02(Tinf,Sat3,Tz,Dn)
915905
!
916906
IMPLICIT NONE
917907

918-
real(dp) abs , am100 , atan , aux , aux1 , aux2 , c0a , cx , d1 , d2 , d3 , d4 , d5 , de100 , deavog , dife , Dn , dpz1 , &
919-
& dpz2
920-
real(dp) dzx , f3 , f4 , gsubx , h2 , h3 , h4 , prod , pz1 , pz2 , q1 , q2 , q3 , q4 , q5 , q6 , r , r1 , r1n
921-
real(dp) r2 , r2n , ra , ras , Sat3 , sksf , sksf34 , soma , sqrt , t100 , t100tz , temp , Tinf , tsubx , txmt0 , Tz , ur1 , &
922-
& ur1h2 , ur2 , ur2h3
923-
real(dp) vra , wr1 , wr2 , x , x2y2 , y , z
924-
INTEGER i
925-
DIMENSION Dn(6)
926-
!
927-
!-----
928-
! R ... UNIVERSAL GAS CONSTANT(JOULES/K MOLE)
929-
! RA... POLAR EARTH RADIUS (KM)
930-
! RAS.. RA**2 (KM**2)
931-
!
932-
DATA r/8.31432_dp/
933-
DATA ra , ras/6356.766_dp , 4.04084739788e+07_dp/
908+
real(dp) :: abs , am100 , atan , aux , aux1 , aux2 , c0a , cx , d1 , d2 , d3 , &
909+
d4 , d5 , de100 , deavog , dife , Dn(6) , dpz1 , &
910+
dpz2 , dzx , f3 , f4 , gsubx , h2 , h3 , h4 , prod , pz1 , pz2 , q1 , &
911+
q2 , q3 , q4 , q5 , q6 , r1 , r1n , r2 , r2n , Sat3 , sksf , sksf34 , &
912+
soma , sqrt , t100 , t100tz , temp , Tinf , tsubx , txmt0 , Tz , ur1 , &
913+
ur1h2 , ur2 , ur2h3 , vra , wr1 , wr2 , x , x2y2 , y , z
914+
INTEGER :: i
915+
916+
real(dp),parameter :: r = 8.31432_dp !! UNIVERSAL GAS CONSTANT(JOULES/K MOLE)
917+
real(dp),parameter :: ra = 6356.766_dp !! POLAR EARTH RADIUS (KM)
918+
real(dp),parameter :: ras = ra*ra !! RA**2 (KM**2)
919+
934920
!
935921
! DENSITY ANALYTICALLY CALCULATED
936922
!
@@ -1103,21 +1089,13 @@ SUBROUTINE stjr03(Tinf,Sat3,Tz,Dn)
11031089
!
11041090
IMPLICIT NONE
11051091

1106-
real(dp) a1 , a1a2a , a2 , al , aux , aux1 , aux2 , d1 , d2 , d3 , d4 , d5 , d6 , Dn , exp , h500 , r , ra , ras , Sat3
1092+
real(dp) a1 , a1a2a , a2 , al , aux , aux1 , aux2 , d1 , d2 , d3 , d4 , d5 , d6 , Dn(6) , exp , h500 , Sat3
11071093
real(dp) tetx , Tinf , tsubx , txmt0 , Tz , tz500 , z
1108-
INTEGER Icount
1109-
COMMON /ncall / Icount
1110-
DIMENSION Dn(6)
1111-
!
1112-
!-----
1113-
!
1114-
! R....UNIVERSAL GAS CONSTANT (JOULES/K MOLE)
1115-
! RA...POLAR EARTH RADIUS (KM)
1116-
! RAS..RA**2 (KM**2)
1117-
!
1118-
DATA r/8.31432_dp/
1119-
DATA ra , ras/6356.766_dp , 4.04084739788e+07_dp/
1120-
Icount = Icount + 1
1094+
1095+
real(dp),parameter :: r = 8.31432_dp !! UNIVERSAL GAS CONSTANT (JOULES/K MOLE)
1096+
real(dp),parameter :: ra = 6356.766_dp !! POLAR EARTH RADIUS (KM)
1097+
real(dp),parameter :: ras = ra*ra !! RA**2 (KM**2)
1098+
11211099
!
11221100
! DENSITY ANALYTICALLY CALCULATED
11231101
!
@@ -1219,15 +1197,11 @@ FUNCTION temlo(Altu,C)
12191197
!
12201198
IMPLICIT NONE
12211199

1222-
real(dp) Altu , auxi , C , higo , higx , temlo , to , zo , zx
1200+
real(dp) Altu , auxi , C(7), higo , higx , temlo
12231201

1224-
DIMENSION C(7)
1225-
!
1226-
!------
1227-
!
1228-
DATA zx/125.0_dp/
1229-
DATA zo/90.0_dp/
1230-
DATA to/188.0_dp/
1202+
real(dp),parameter :: zx = 125.0_dp
1203+
real(dp),parameter :: zo = 90.0_dp
1204+
real(dp),parameter :: to = 188.0_dp
12311205

12321206
higx = Altu - zx
12331207
higo = Altu - zo
@@ -1287,14 +1261,12 @@ SUBROUTINE sealat(Tyfr,Sudc,Rlat,Altu,Al)
12871261
!
12881262
IMPLICIT NONE
12891263

1290-
real(dp) Al(6) , Altu , cr(6) , delz , dslm , dslt , esse , pcap , pitw , Rlat , sila , Sudc , Tyfr
1291-
INTEGER i
1292-
!
1293-
!------
1294-
!
1295-
DATA pitw/6.28318530718_dp/
1264+
real(dp) :: Al(6) , Altu , delz , dslm , dslt , esse , pcap , Rlat , sila , Sudc , Tyfr
1265+
INTEGER :: i
12961266

1297-
DATA cr/ - 0.79_dp , 0_dp , 0_dp , 0_dp , -.16_dp , 0_dp/
1267+
real(dp),parameter :: pi = acos(-1.0_dp)
1268+
real(dp),parameter :: pitw = 2.0_dp * pi
1269+
real(dp),dimension(6),parameter :: cr = [ -0.79_dp , 0.0_dp , 0.0_dp , 0.0_dp , -0.16_dp , 0.0_dp ]
12981270

12991271
sila = sin(Rlat)
13001272
dslt = Sudc*sila/0.409157536545_dp
@@ -1345,11 +1317,10 @@ SUBROUTINE semian(Tyfr,Altu,Alco)
13451317
!
13461318
IMPLICIT NONE
13471319

1348-
real(dp) Alco , Altu , auxi , foft , goft , pitw , tauc , Tyfr
1349-
!
1350-
!------
1351-
!
1352-
DATA pitw/6.28318530718_dp/
1320+
real(dp) :: Alco , Altu , auxi , foft , goft , tauc , Tyfr
1321+
1322+
real(dp),parameter :: pi = acos(-1.0_dp)
1323+
real(dp),parameter :: pitw = 2.0_dp * pi
13531324

13541325
auxi = 0.04_dp*Altu*Altu/1.0e+04_dp + 0.05_dp
13551326
foft = auxi*exp(-0.25e-02_dp*Altu)

0 commit comments

Comments
 (0)