diff --git a/for_src/density/check_density.f90 b/for_src/density/check_density.f90 index e767ab6..059de24 100644 --- a/for_src/density/check_density.f90 +++ b/for_src/density/check_density.f90 @@ -33,10 +33,10 @@ program check_density do i=1,nx do j=1,ny do k=1,nz - T(i) = -2.+27.*(i-1.0)/nx - S(j) = 33+4*(j-1.0)/ny - !S(j) = 35*(j-1.0)/ny - P(k) = 5000*(k-1.)/nz + T(i) = -2.d0+27.d0*(i-1.0d0)/nx + S(j) = 33+4*(j-1.0d0)/ny + !S(j) = 35*(j-1.0d0)/ny + P(k) = 5000*(k-1.d0)/nz rho3(i,j,k) = gsw_rho(S(j),T(i),P(k)) rho2(i,j,k) = nonlin2_eq_of_state_rho(S(j),T(i),P(k)) drho3dT(i,j,k) = gsw_drhodT(S(j),T(i),P(k)) @@ -49,8 +49,8 @@ program check_density Hd2(i,j,k) = nonlin2_eq_of_state_dyn_enthalpy(S(j),T(i),P(k)) dHd3dT(i,j,k) = gsw_dHdT(S(j),T(i),P(k)) dHd3dS(i,j,k) = gsw_dHdS(S(j),T(i),P(k)) - dHd2dT(i,j,k) = nonlin2_eq_of_state_int_drhodT(T(i),P(k))*(-9.81/1024.) - dHd2dS(i,j,k) = nonlin2_eq_of_state_int_drhodS(P(k))*(-9.81/1024.) + dHd2dT(i,j,k) = nonlin2_eq_of_state_int_drhodT(T(i),P(k))*(-9.81d0/1024.d0) + dHd2dS(i,j,k) = nonlin2_eq_of_state_int_drhodS(P(k))*(-9.81d0/1024.d0) enddo enddo enddo diff --git a/for_src/density/density.f90 b/for_src/density/density.f90 index e0f1a21..cb7f565 100644 --- a/for_src/density/density.f90 +++ b/for_src/density/density.f90 @@ -4,14 +4,14 @@ module linear_eq_of_state !========================================================================== -! linear equation of state -! input is Salinity sa in g/kg, -! pot. temperature ct in deg C +! linear equation of state +! input is Salinity sa in g/kg, +! pot. temperature ct in deg C !========================================================================== implicit none - real*8,parameter,private :: rho0 = 1024.0,theta0 = 283.0-273.15, S0 = 35.0 - real*8,parameter,private :: betaT = 1.67d-4, betaS = 0.78d-3 - real*8,parameter,private :: grav = 9.81, z0=0.0 + real*8,parameter,private :: rho0 = 1024.0d0,theta0 = 283.0d0-273.15d0, S0 = 35.0d0 + real*8,parameter,private :: betaT = 1.67d-4, betaS = 0.78d-3 + real*8,parameter,private :: grav = 9.81d0, z0=0.0d0 contains real*8 function linear_eq_of_state_rho(sa,ct) @@ -23,7 +23,7 @@ module linear_eq_of_state real*8 :: sa,ct,p, zz,thetas zz=-p-z0 thetas = ct-theta0 - linear_eq_of_state_dyn_enthalpy = grav*zz*(-betaT*thetas+betaS*(sa-S0) ) + linear_eq_of_state_dyn_enthalpy = grav*zz*(-betaT*thetas+betaS*(sa-S0) ) end function real*8 function linear_eq_of_state_salt(rho,ct) @@ -40,7 +40,7 @@ module linear_eq_of_state end function real*8 function linear_eq_of_state_drhodp() - linear_eq_of_state_drhodp = 0.0 + linear_eq_of_state_drhodp = 0.0d0 end function end module linear_eq_of_state @@ -50,13 +50,13 @@ end module linear_eq_of_state module nonlin1_eq_of_state !========================================================================== ! non-linear equation of state from Vallis 2008 -! input is Salinity sa in g/kg, +! input is Salinity sa in g/kg, ! pot. temperature ct in deg C , no pressure dependency !========================================================================== implicit none - real*8,parameter,private :: rho0 = 1024.0,theta0 = 283.0-273.15, S0 = 35.0 - real*8,parameter,private :: betaT = 1.67d-4, betaTs = 1d-5/2., betaS = 0.78d-3 - real*8,parameter,private :: grav = 9.81, z0=0.0 + real*8,parameter,private :: rho0 = 1024.0d0,theta0 = 283.0d0-273.15d0, S0 = 35.0d0 + real*8,parameter,private :: betaT = 1.67d-4, betaTs = 1d-5/2.d0, betaS = 0.78d-3 + real*8,parameter,private :: grav = 9.81d0, z0=0.0d0 contains real*8 function nonlin1_eq_of_state_rho(sa,ct) @@ -69,7 +69,7 @@ module nonlin1_eq_of_state real*8 :: sa,ct,p, zz,thetas zz=-p-z0 thetas = ct-theta0 - nonlin1_eq_of_state_dyn_enthalpy = grav*zz*(-betaT*thetas-betaTs*thetas**2+betaS*(sa-S0) ) + nonlin1_eq_of_state_dyn_enthalpy = grav*zz*(-betaT*thetas-betaTs*thetas**2+betaS*(sa-S0) ) end function real*8 function nonlin1_eq_of_state_salt(rho,ct) @@ -89,7 +89,7 @@ module nonlin1_eq_of_state end function real*8 function nonlin1_eq_of_state_drhodp() - nonlin1_eq_of_state_drhodp = 0.0 + nonlin1_eq_of_state_drhodp = 0.0d0 end function end module nonlin1_eq_of_state @@ -98,13 +98,13 @@ end module nonlin1_eq_of_state module nonlin2_eq_of_state !========================================================================== ! non-linear equation of state from Vallis 2008 -! input is Salinity sa in g/kg, -! pot. temperature ct in deg C and +! input is Salinity sa in g/kg, +! pot. temperature ct in deg C and ! pressure p in dbar !========================================================================== implicit none - real*8,parameter,private :: rho0 = 1024.0,z0 = 0.0, theta0 = 283.0-273.15, S0 = 35.0 - real*8,parameter,private :: grav=9.81, cs0 = 1490.0, betaT = 1.67d-4, betaTs = 1d-5 + real*8,parameter,private :: rho0 = 1024.0d0,z0 = 0.0d0, theta0 = 283.0d0-273.15d0, S0 = 35.0d0 + real*8,parameter,private :: grav=9.81d0, cs0 = 1490.0d0, betaT = 1.67d-4, betaTs = 1d-5 real*8,parameter,private :: betaS = 0.78d-3, gammas = 1.1d-8 contains @@ -115,13 +115,13 @@ module nonlin2_eq_of_state nonlin2_eq_of_state_rho = & - (grav*zz/cs0**2 +betaT*(1-gammas*grav*zz*rho0)*thetas + betaTs/2*thetas**2-betaS*(sa-S0) )*rho0 end function - + real*8 function nonlin2_eq_of_state_dyn_enthalpy(sa,ct,p) real*8 :: sa,ct,p, zz,thetas zz=-p-z0 thetas = ct-theta0 - nonlin2_eq_of_state_dyn_enthalpy = grav*0.5*zz**2*( -grav/cs0**2 + betaT*grav*rho0*gammas*thetas ) & - +grav*zz*(-betaT*thetas-betaTs*thetas**2+betaS*(sa-S0) ) + nonlin2_eq_of_state_dyn_enthalpy = grav*0.5d0*zz**2*( -grav/cs0**2 + betaT*grav*rho0*gammas*thetas ) & + +grav*zz*(-betaT*thetas-betaTs*thetas**2+betaS*(sa-S0) ) end function real*8 function nonlin2_eq_of_state_salt(rho,ct,p) @@ -131,29 +131,29 @@ module nonlin2_eq_of_state nonlin2_eq_of_state_salt = & (rho/rho0 + (grav*zz/cs0**2 +betaT*(1-gammas*grav*zz*rho0)*thetas + betaTs/2*thetas**2 ))/betaS + S0 end function - + real*8 function nonlin2_eq_of_state_drhodT(ct,p) real*8 :: ct,p, zz,thetas zz=-p-z0 thetas = ct-theta0 nonlin2_eq_of_state_drhodT = - ( betaT*(1-gammas*grav*zz*rho0) + betaTs*thetas )*rho0 end function - + real*8 function nonlin2_eq_of_state_drhodS() nonlin2_eq_of_state_drhodS = betaS*rho0 end function - + real*8 function nonlin2_eq_of_state_drhodp(ct) real*8 :: ct,thetas thetas = ct-theta0 - nonlin2_eq_of_state_drhodp = 1/cs0**2 -betaT*gammas*rho0*thetas + nonlin2_eq_of_state_drhodp = 1/cs0**2 -betaT*gammas*rho0*thetas end function real*8 function nonlin2_eq_of_state_int_drhodT(ct,p) real*8 :: ct,p, zz,thetas zz=-p-z0 thetas = ct-theta0 - nonlin2_eq_of_state_int_drhodT = rho0*zz*(betaT+betaTs*thetas) - rho0*betaT*gammas*grav*rho0*zz**2/2 + nonlin2_eq_of_state_int_drhodT = rho0*zz*(betaT+betaTs*thetas) - rho0*betaT*gammas*grav*rho0*zz**2/2 end function real*8 function nonlin2_eq_of_state_int_drhodS(p) @@ -172,13 +172,13 @@ end module nonlin2_eq_of_state module nonlin3_eq_of_state !========================================================================== ! non-linear equation of state, no salinity dependency -! input is Salinity sa in g/kg, +! input is Salinity sa in g/kg, ! pot. temperature ct in deg C , no pressure dependency !========================================================================== implicit none - real*8,parameter,private :: rho0 = 1024.0,theta0 = 283.0-273.15, S0 = 35.0 - real*8,parameter,private :: betaT = 1.67d-4, betaTs = 1d-5/2., betaS = 0 - real*8,parameter,private :: grav = 9.81, z0=0.0 + real*8,parameter,private :: rho0 = 1024.0d0,theta0 = 283.0d0-273.15d0, S0 = 35.0d0 + real*8,parameter,private :: betaT = 1.67d-4, betaTs = 1d-5/2.d0, betaS = 0 + real*8,parameter,private :: grav = 9.81d0, z0=0.0d0 contains real*8 function nonlin3_eq_of_state_rho(sa,ct) @@ -191,7 +191,7 @@ module nonlin3_eq_of_state real*8 :: sa,ct,p, zz,thetas zz=-p-z0 thetas = ct-theta0 - nonlin3_eq_of_state_dyn_enthalpy = grav*zz*(-betaT*thetas-betaTs*thetas**2+betaS*(sa-S0) ) + nonlin3_eq_of_state_dyn_enthalpy = grav*zz*(-betaT*thetas-betaTs*thetas**2+betaS*(sa-S0) ) end function real*8 function nonlin3_eq_of_state_salt(rho,ct) @@ -211,7 +211,7 @@ module nonlin3_eq_of_state end function real*8 function nonlin3_eq_of_state_drhodp() - nonlin3_eq_of_state_drhodp = 0.0 + nonlin3_eq_of_state_drhodp = 0.0d0 end function end module nonlin3_eq_of_state @@ -222,66 +222,66 @@ end module nonlin3_eq_of_state module gsw_eq_of_state !========================================================================== ! in-situ density, dynamic enthalpy and derivatives - ! from Absolute Salinity and Conservative + ! from Absolute Salinity and Conservative ! Temperature, using the computationally-efficient 48-term expression for ! density in terms of SA, CT and p (IOC et al., 2010). !========================================================================== implicit none - real*8, private, parameter :: v01 = 9.998420897506056d+2 + real*8, private, parameter :: v01 = 9.998420897506056d+2 real*8, private, parameter :: v02 = 2.839940833161907d0 - real*8, private, parameter :: v03 = -3.147759265588511d-2 + real*8, private, parameter :: v03 = -3.147759265588511d-2 real*8, private, parameter :: v04 = 1.181805545074306d-3 - real*8, private, parameter :: v05 = -6.698001071123802d0 + real*8, private, parameter :: v05 = -6.698001071123802d0 real*8, private, parameter :: v06 = -2.986498947203215d-2 - real*8, private, parameter :: v07 = 2.327859407479162d-4 + real*8, private, parameter :: v07 = 2.327859407479162d-4 real*8, private, parameter :: v08 = -3.988822378968490d-2 - real*8, private, parameter :: v09 = 5.095422573880500d-4 + real*8, private, parameter :: v09 = 5.095422573880500d-4 real*8, private, parameter :: v10 = -1.426984671633621d-5 - real*8, private, parameter :: v11 = 1.645039373682922d-7 + real*8, private, parameter :: v11 = 1.645039373682922d-7 real*8, private, parameter :: v12 = -2.233269627352527d-2 - real*8, private, parameter :: v13 = -3.436090079851880d-4 + real*8, private, parameter :: v13 = -3.436090079851880d-4 real*8, private, parameter :: v14 = 3.726050720345733d-6 - real*8, private, parameter :: v15 = -1.806789763745328d-4 + real*8, private, parameter :: v15 = -1.806789763745328d-4 real*8, private, parameter :: v16 = 6.876837219536232d-7 - real*8, private, parameter :: v17 = -3.087032500374211d-7 + real*8, private, parameter :: v17 = -3.087032500374211d-7 real*8, private, parameter :: v18 = -1.988366587925593d-8 - real*8, private, parameter :: v19 = -1.061519070296458d-11 + real*8, private, parameter :: v19 = -1.061519070296458d-11 real*8, private, parameter :: v20 = 1.550932729220080d-10 real*8, private, parameter :: v21 = 1.0d0 - real*8, private, parameter :: v22 = 2.775927747785646d-3 + real*8, private, parameter :: v22 = 2.775927747785646d-3 real*8, private, parameter :: v23 = -2.349607444135925d-5 - real*8, private, parameter :: v24 = 1.119513357486743d-6 + real*8, private, parameter :: v24 = 1.119513357486743d-6 real*8, private, parameter :: v25 = 6.743689325042773d-10 - real*8, private, parameter :: v26 = -7.521448093615448d-3 + real*8, private, parameter :: v26 = -7.521448093615448d-3 real*8, private, parameter :: v27 = -2.764306979894411d-5 - real*8, private, parameter :: v28 = 1.262937315098546d-7 + real*8, private, parameter :: v28 = 1.262937315098546d-7 real*8, private, parameter :: v29 = 9.527875081696435d-10 - real*8, private, parameter :: v30 = -1.811147201949891d-11 + real*8, private, parameter :: v30 = -1.811147201949891d-11 real*8, private, parameter :: v31 = -3.303308871386421d-5 - real*8, private, parameter :: v32 = 3.801564588876298d-7 + real*8, private, parameter :: v32 = 3.801564588876298d-7 real*8, private, parameter :: v33 = -7.672876869259043d-9 - real*8, private, parameter :: v34 = -4.634182341116144d-11 + real*8, private, parameter :: v34 = -4.634182341116144d-11 real*8, private, parameter :: v35 = 2.681097235569143d-12 - real*8, private, parameter :: v36 = 5.419326551148740d-6 + real*8, private, parameter :: v36 = 5.419326551148740d-6 real*8, private, parameter :: v37 = -2.742185394906099d-5 - real*8, private, parameter :: v38 = -3.212746477974189d-7 + real*8, private, parameter :: v38 = -3.212746477974189d-7 real*8, private, parameter :: v39 = 3.191413910561627d-9 - real*8, private, parameter :: v40 = -1.931012931541776d-12 + real*8, private, parameter :: v40 = -1.931012931541776d-12 real*8, private, parameter :: v41 = -1.105097577149576d-7 - real*8, private, parameter :: v42 = 6.211426728363857d-10 + real*8, private, parameter :: v42 = 6.211426728363857d-10 real*8, private, parameter :: v43 = -1.119011592875110d-10 - real*8, private, parameter :: v44 = -1.941660213148725d-11 + real*8, private, parameter :: v44 = -1.941660213148725d-11 real*8, private, parameter :: v45 = -1.864826425365600d-14 - real*8, private, parameter :: v46 = 1.119522344879478d-14 + real*8, private, parameter :: v46 = 1.119522344879478d-14 real*8, private, parameter :: v47 = -1.200507748551599d-15 - real*8, private, parameter :: v48 = 6.057902487546866d-17 - real*8, parameter, private :: rho0 = 1024.0 + real*8, private, parameter :: v48 = 6.057902487546866d-17 + real*8, parameter, private :: rho0 = 1024.0d0 contains !========================================================================== - real*8 function gsw_rho(sa,ct,p) + real*8 function gsw_rho(sa,ct,p) ! density as a function of T, S, and p ! sa : Absolute Salinity [g/kg] ! ct : Conservative Temperature [deg C] @@ -300,7 +300,7 @@ module gsw_eq_of_state + sqrtsa*(v31 + ct*(v32 + ct*(v33 + ct*(v34 + v35*ct))))) & + p*(v37 + ct*(v38 + ct*(v39 + v40*ct)) & + sa*(v41 + v42*ct) + p*(v43 + ct*(v44 + v45*ct + v46*sa) & - + p*(v47 + v48*ct))) + + p*(v47 + v48*ct))) gsw_rho = v_hat_denominator/v_hat_numerator - rho0 end function @@ -313,37 +313,37 @@ module gsw_eq_of_state ! p : sea pressure [dbar] !========================================================================== real*8, intent(in) :: sa, ct, p - real*8 , parameter :: a01 = 2.839940833161907d0 + real*8 , parameter :: a01 = 2.839940833161907d0 real*8, parameter :: a02 = -6.295518531177023d-2 - real*8 ,parameter :: a03 = 3.545416635222918d-3 + real*8 ,parameter :: a03 = 3.545416635222918d-3 real*8, parameter :: a04 = -2.986498947203215d-2 - real*8 ,parameter :: a05 = 4.655718814958324d-4 + real*8 ,parameter :: a05 = 4.655718814958324d-4 real*8, parameter :: a06 = 5.095422573880500d-4 - real*8 ,parameter :: a07 = -2.853969343267241d-5 + real*8 ,parameter :: a07 = -2.853969343267241d-5 real*8, parameter :: a08 = 4.935118121048767d-7 - real*8 ,parameter :: a09 = -3.436090079851880d-4 + real*8 ,parameter :: a09 = -3.436090079851880d-4 real*8, parameter :: a10 = 7.452101440691467d-6 - real*8 ,parameter :: a11 = 6.876837219536232d-7 + real*8 ,parameter :: a11 = 6.876837219536232d-7 real*8, parameter :: a12 = -1.988366587925593d-8 - real*8 ,parameter :: a13 = -2.123038140592916d-11 + real*8 ,parameter :: a13 = -2.123038140592916d-11 real*8, parameter :: a14 = 2.775927747785646d-3 - real*8 ,parameter :: a15 = -4.699214888271850d-5 + real*8 ,parameter :: a15 = -4.699214888271850d-5 real*8, parameter :: a16 = 3.358540072460230d-6 - real*8 ,parameter :: a17 = 2.697475730017109d-9 + real*8 ,parameter :: a17 = 2.697475730017109d-9 real*8, parameter :: a18 = -2.764306979894411d-5 - real*8 ,parameter :: a19 = 2.525874630197091d-7 + real*8 ,parameter :: a19 = 2.525874630197091d-7 real*8, parameter :: a20 = 2.858362524508931d-9 - real*8 ,parameter :: a21 = -7.244588807799565d-11 + real*8 ,parameter :: a21 = -7.244588807799565d-11 real*8, parameter :: a22 = 3.801564588876298d-7 - real*8 ,parameter :: a23 = -1.534575373851809d-8 + real*8 ,parameter :: a23 = -1.534575373851809d-8 real*8, parameter :: a24 = -1.390254702334843d-10 - real*8 ,parameter :: a25 = 1.072438894227657d-11 + real*8 ,parameter :: a25 = 1.072438894227657d-11 real*8, parameter :: a26 = -3.212746477974189d-7 - real*8 ,parameter :: a27 = 6.382827821123254d-9 + real*8 ,parameter :: a27 = 6.382827821123254d-9 real*8, parameter :: a28 = -5.793038794625329d-12 - real*8 ,parameter :: a29 = 6.211426728363857d-10 + real*8 ,parameter :: a29 = 6.211426728363857d-10 real*8, parameter :: a30 = -1.941660213148725d-11 - real*8 ,parameter :: a31 = -3.729652850731201d-14 + real*8 ,parameter :: a31 = -3.729652850731201d-14 real*8, parameter :: a32 = 1.119522344879478d-14 real*8 ,parameter :: a33 = 6.057902487546866d-17 real*8 :: sqrtsa, v_hat_denominator, v_hat_numerator @@ -358,7 +358,7 @@ module gsw_eq_of_state + sa*(v26 + ct*(v27 + ct*(v28 + ct*(v29 + v30*ct))) + v36*sa & + sqrtsa*(v31 + ct*(v32 + ct*(v33 + ct*(v34 + v35*ct))))) + p*(v37 + ct*(v38 + ct*(v39 + v40*ct)) & + sa*(v41 + v42*ct) + p*(v43 + ct*(v44 + v45*ct + v46*sa) + p*(v47 + v48*ct))) - + dvhatden_dct = a01 + ct*(a02 + a03*ct) + sa*(a04 + a05*ct + sqrtsa*(a06 + ct*(a07 + a08*ct))) & + p*(a09 + a10*ct + a11*sa + p*(a12 + a13*ct)) @@ -379,29 +379,29 @@ module gsw_eq_of_state ! p : sea pressure [dbar] !========================================================================== real*8, intent(in) :: sa, ct, p - real*8 , parameter :: b01 = -6.698001071123802d0 + real*8 , parameter :: b01 = -6.698001071123802d0 real*8 , parameter :: b02 = -2.986498947203215d-2 - real*8 , parameter :: b03 = 2.327859407479162d-4 + real*8 , parameter :: b03 = 2.327859407479162d-4 real*8 , parameter :: b04 = -5.983233568452735d-2 - real*8 , parameter :: b05 = 7.643133860820750d-4 + real*8 , parameter :: b05 = 7.643133860820750d-4 real*8 , parameter :: b06 = -2.140477007450431d-5 - real*8 , parameter :: b07 = 2.467559060524383d-7 + real*8 , parameter :: b07 = 2.467559060524383d-7 real*8 , parameter :: b08 = -1.806789763745328d-4 - real*8 , parameter :: b09 = 6.876837219536232d-7 + real*8 , parameter :: b09 = 6.876837219536232d-7 real*8 , parameter :: b10 = 1.550932729220080d-10 - real*8 , parameter :: b11 = -7.521448093615448d-3 + real*8 , parameter :: b11 = -7.521448093615448d-3 real*8 , parameter :: b12 = -2.764306979894411d-5 - real*8 , parameter :: b13 = 1.262937315098546d-7 + real*8 , parameter :: b13 = 1.262937315098546d-7 real*8 , parameter :: b14 = 9.527875081696435d-10 - real*8 , parameter :: b15 = -1.811147201949891d-11 + real*8 , parameter :: b15 = -1.811147201949891d-11 real*8 , parameter :: b16 = -4.954963307079632d-5 - real*8 , parameter :: b17 = 5.702346883314446d-7 + real*8 , parameter :: b17 = 5.702346883314446d-7 real*8 , parameter :: b18 = -1.150931530388857d-8 - real*8 , parameter :: b19 = -6.951273511674217d-11 + real*8 , parameter :: b19 = -6.951273511674217d-11 real*8 , parameter :: b20 = 4.021645853353715d-12 - real*8 , parameter :: b21 = 1.083865310229748d-5 + real*8 , parameter :: b21 = 1.083865310229748d-5 real*8 , parameter :: b22 = -1.105097577149576d-7 - real*8 , parameter :: b23 = 6.211426728363857d-10 + real*8 , parameter :: b23 = 6.211426728363857d-10 real*8 , parameter :: b24 = 1.119522344879478d-14 real*8 :: sqrtsa, v_hat_denominator, v_hat_numerator real*8 :: dvhatden_dsa, dvhatnum_dsa, rho, rec_num @@ -416,9 +416,9 @@ module gsw_eq_of_state + sqrtsa*(v31 + ct*(v32 + ct*(v33 + ct*(v34 + v35*ct))))) & + p*(v37 + ct*(v38 + ct*(v39 + v40*ct)) + sa*(v41 + v42*ct) + p*(v43 + ct*(v44 + v45*ct + v46*sa) & + p*(v47 + v48*ct))) - + dvhatden_dsa = b01 + ct*(b02 + b03*ct) + sqrtsa*(b04 + ct*(b05 + ct*(b06 + b07*ct))) & - + p*(b08 + b09*ct + b10*p) + + p*(b08 + b09*ct + b10*p) dvhatnum_dsa = b11 + ct*(b12 + ct*(b13 + ct*(b14 + b15*ct))) & + sqrtsa*(b16 + ct*(b17 + ct*(b18 + ct*(b19 + b20*ct)))) & @@ -438,25 +438,25 @@ module gsw_eq_of_state ! p : sea pressure [dbar] !========================================================================== real*8, intent(in) :: sa, ct, p - real*8 , parameter :: c01 = -2.233269627352527d-2 + real*8 , parameter :: c01 = -2.233269627352527d-2 real*8 , parameter :: c02 = -3.436090079851880d-4 - real*8 , parameter :: c03 = 3.726050720345733d-6 + real*8 , parameter :: c03 = 3.726050720345733d-6 real*8 , parameter :: c04 = -1.806789763745328d-4 - real*8 , parameter :: c05 = 6.876837219536232d-7 + real*8 , parameter :: c05 = 6.876837219536232d-7 real*8 , parameter :: c06 = -6.174065000748422d-7 - real*8 , parameter :: c07 = -3.976733175851186d-8 + real*8 , parameter :: c07 = -3.976733175851186d-8 real*8 , parameter :: c08 = -2.123038140592916d-11 - real*8 , parameter :: c09 = 3.101865458440160d-10 + real*8 , parameter :: c09 = 3.101865458440160d-10 real*8 , parameter :: c10 = -2.742185394906099d-5 - real*8 , parameter :: c11 = -3.212746477974189d-7 + real*8 , parameter :: c11 = -3.212746477974189d-7 real*8 , parameter :: c12 = 3.191413910561627d-9 - real*8 , parameter :: c13 = -1.931012931541776d-12 + real*8 , parameter :: c13 = -1.931012931541776d-12 real*8 , parameter :: c14 = -1.105097577149576d-7 - real*8 , parameter :: c15 = 6.211426728363857d-10 + real*8 , parameter :: c15 = 6.211426728363857d-10 real*8 , parameter :: c16 = -2.238023185750219d-10 - real*8 , parameter :: c17 = -3.883320426297450d-11 + real*8 , parameter :: c17 = -3.883320426297450d-11 real*8 , parameter :: c18 = -3.729652850731201d-14 - real*8 , parameter :: c19 = 2.239044689758956d-14 + real*8 , parameter :: c19 = 2.239044689758956d-14 real*8 , parameter :: c20 = -3.601523245654798d-15 real*8 , parameter :: c21 = 1.817370746264060d-16, pa2db = 1d-4 real*8 :: sqrtsa, v_hat_denominator, v_hat_numerator @@ -485,14 +485,14 @@ module gsw_eq_of_state !========================================================================== - real*8 function gsw_dyn_enthalpy(sa,ct,p) + real*8 function gsw_dyn_enthalpy(sa,ct,p) !========================================================================== ! Calculates dynamic enthalpy of seawater using the computationally ! efficient 48-term expression for density in terms of SA, CT and p ! (IOC et al., 2010) - ! - ! A component due to the constant reference density in Boussinesq + ! + ! A component due to the constant reference density in Boussinesq ! approximation is removed ! ! sa : Absolute Salinity [g/kg] @@ -519,7 +519,7 @@ module gsw_eq_of_state + sqrtsa*(v08 + ct*(v09 + ct*(v10 + v11*ct)))) b1 = 0.5d0*(v12 + ct*(v13 + v14*ct) + sa*(v15 + v16*ct)) b2 = v17 + ct*(v18 + v19*ct) + v20*sa - b1sq = b1*b1 + b1sq = b1*b1 sqrt_disc = sqrt(b1sq - b0*b2) cn = a0 + (2*a3*b0*b1/b2 - a2*b0)/b2 cm = a1 + (4*a3*b1sq/b2 - a3*b0 - 2*a2*b1)/b2 @@ -768,5 +768,3 @@ module gsw_eq_of_state end function end module gsw_eq_of_state - - diff --git a/for_src/density/get_rho.f90 b/for_src/density/get_rho.f90 index c9214e1..4e04e6a 100644 --- a/for_src/density/get_rho.f90 +++ b/for_src/density/get_rho.f90 @@ -2,7 +2,7 @@ -real*8 function get_rho(salt_loc,temp_loc,press) +real*8 function get_rho(salt_loc,temp_loc,press) !----------------------------------------------------------------------- ! calculate density as a function of temperature, salinity and pressure !----------------------------------------------------------------------- @@ -25,7 +25,7 @@ else if (eq_of_state_type == 4) then get_rho = nonlin3_eq_of_state_rho(salt_loc,temp_loc) else if (eq_of_state_type == 5) then get_rho = gsw_rho(salt_loc,temp_loc,press) -else +else get_rho=0 call halt_stop(' unknown equation of state in get_rho') endif @@ -33,7 +33,7 @@ end function get_rho -real*8 function get_dyn_enthalpy(salt_loc,temp_loc,press) +real*8 function get_dyn_enthalpy(salt_loc,temp_loc,press) !----------------------------------------------------------------------- ! calculate dynamic enthalpy as a function of temperature, salinity and pressure !----------------------------------------------------------------------- @@ -56,7 +56,7 @@ else if (eq_of_state_type == 4) then get_dyn_enthalpy = nonlin3_eq_of_state_dyn_enthalpy(salt_loc,temp_loc,press) else if (eq_of_state_type == 5) then get_dyn_enthalpy = gsw_dyn_enthalpy(salt_loc,temp_loc,press) -else +else get_dyn_enthalpy=0 call halt_stop(' unknown equation of state in get_dyn_enthalpy') endif @@ -64,7 +64,7 @@ end function get_dyn_enthalpy -real*8 function get_salt(rho_loc,temp_loc,press_loc) +real*8 function get_salt(rho_loc,temp_loc,press_loc) !----------------------------------------------------------------------- ! calculate salinity as a function of density, temperature and pressure !----------------------------------------------------------------------- @@ -84,14 +84,14 @@ else if (eq_of_state_type == 3) then get_salt = nonlin2_eq_of_state_salt(rho_loc,temp_loc,press_loc) else if (eq_of_state_type == 4) then get_salt = nonlin3_eq_of_state_salt(rho_loc,temp_loc) -else +else get_salt=0 call halt_stop(' unknown equation of state in get_salt') endif end function get_salt -real*8 function get_drhodT(salt_loc,temp_loc,press_loc) +real*8 function get_drhodT(salt_loc,temp_loc,press_loc) !----------------------------------------------------------------------- ! calculate drho/dT as a function of temperature, salinity and pressure !----------------------------------------------------------------------- @@ -114,14 +114,14 @@ else if (eq_of_state_type == 4) then get_drhodT = nonlin3_eq_of_state_drhodT(temp_loc) else if (eq_of_state_type == 5) then get_drhodT = gsw_drhodT(salt_loc,temp_loc,press_loc) -else +else get_drhodT = 0 call halt_stop(' unknown equation of state in get_rho') endif end function get_drhodT -real*8 function get_drhodS(salt_loc,temp_loc,press_loc) +real*8 function get_drhodS(salt_loc,temp_loc,press_loc) !----------------------------------------------------------------------- ! calculate drho/dS as a function of temperature, salinity and pressure !----------------------------------------------------------------------- @@ -144,14 +144,14 @@ else if (eq_of_state_type == 4) then get_drhodS = nonlin3_eq_of_state_drhodS() else if (eq_of_state_type == 5) then get_drhodS = gsw_drhodS(salt_loc,temp_loc,press_loc) -else +else get_drhodS = 0 call halt_stop(' unknown equation of state in get_rho') endif end function get_drhodS -real*8 function get_drhodp(salt_loc,temp_loc,press_loc) +real*8 function get_drhodp(salt_loc,temp_loc,press_loc) !----------------------------------------------------------------------- ! calculate drho/dP as a function of temperature, salinity and pressure !----------------------------------------------------------------------- @@ -174,7 +174,7 @@ else if (eq_of_state_type == 4) then get_drhodp = nonlin3_eq_of_state_drhodp() else if (eq_of_state_type == 5) then get_drhodp = gsw_drhodp(salt_loc,temp_loc,press_loc) -else +else get_drhodp = 0 call halt_stop(' unknown equation of state in get_drhodp') endif @@ -182,7 +182,7 @@ end function get_drhodP -real*8 function get_int_drhodT(salt_loc,temp_loc,press_loc) +real*8 function get_int_drhodT(salt_loc,temp_loc,press_loc) !----------------------------------------------------------------------- ! calculate int_z^0 drho/dT dz' as a function of temperature, salinity and pressure !----------------------------------------------------------------------- @@ -204,15 +204,15 @@ elseif (eq_of_state_type == 3) then elseif (eq_of_state_type == 4) then get_int_drhodT = press_loc*nonlin3_eq_of_state_drhodT(temp_loc) elseif (eq_of_state_type == 5) then - get_int_drhodT = -(1024.0/9.81)*gsw_dHdT(salt_loc,temp_loc,press_loc) -else + get_int_drhodT = -(1024.0d0/9.81d0)*gsw_dHdT(salt_loc,temp_loc,press_loc) +else get_int_drhodT = 0 call halt_stop(' unknown equation of state in get_int_drhodT') endif -end function +end function -real*8 function get_int_drhodS(salt_loc,temp_loc,press_loc) +real*8 function get_int_drhodS(salt_loc,temp_loc,press_loc) !----------------------------------------------------------------------- ! calculate int_z^0 drho/dS dz' as a function of temperature, salinity and pressure !----------------------------------------------------------------------- @@ -234,9 +234,9 @@ elseif (eq_of_state_type == 3) then elseif (eq_of_state_type == 4) then get_int_drhodS = press_loc*nonlin3_eq_of_state_drhodS() elseif (eq_of_state_type == 5) then - get_int_drhodS = -(1024.0/9.81)*gsw_dHdS(salt_loc,temp_loc,press_loc) -else + get_int_drhodS = -(1024.0d0/9.81d0)*gsw_dHdS(salt_loc,temp_loc,press_loc) +else get_int_drhodS = 0 call halt_stop(' unknown equation of state in get_int_rho') endif -end function +end function diff --git a/for_src/diagnostics/diag_averages.f90 b/for_src/diagnostics/diag_averages.f90 index 749b92f..d929cb6 100644 --- a/for_src/diagnostics/diag_averages.f90 +++ b/for_src/diagnostics/diag_averages.f90 @@ -24,7 +24,7 @@ end module diag_averages_module subroutine register_average(name,longname,units,grid,var2D,var3D,is3D) !======================================================================= -! register a variables to be averaged +! register a variables to be averaged ! this routine may be called by user in set_diagnostics ! name : NetCDF variables name (must be unique) ! longname: long name @@ -45,7 +45,7 @@ subroutine register_average(name,longname,units,grid,var2D,var3D,is3D) real*8,target :: var3D(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) logical :: is3D integer :: n - if (.not. enable_diag_averages) then + if (.not. enable_diag_averages) then if (my_pe==0) print*,' switch on enable_diag_averages to use time averaging' return endif @@ -61,7 +61,7 @@ subroutine register_average(name,longname,units,grid,var2D,var3D,is3D) call halt_stop(' in register_average') endif enddo - number_diags = number_diags + 1 + number_diags = number_diags + 1 ! check for overflow if (number_diags > max_number_diags) then if (my_pe==0) print*,' too many diagnostics, increase max_number_diags' @@ -158,7 +158,7 @@ subroutine write_averages call ncendf(ncid, iret) iret=nf_inq_dimlen(ncid, itimedim,ilen) ilen=ilen+1 - fxa = itt*dt_tracer/86400.0 + fxa = itt*dt_tracer/86400.0d0 iret=nf_inq_varid(ncid,'Time',itimeid) iret= nf_put_vara_double(ncid,itimeid,ilen,1,fxa) endif @@ -166,28 +166,28 @@ subroutine write_averages if (diag_is3D(n)) then do k=1,nz bloc(is_pe:ie_pe,js_pe:je_pe) = diag_sum_var3D(n)%a(is_pe:ie_pe,js_pe:je_pe,k)/nitts - if (diag_grid(n)(1:3) =='TTT') where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval - if (diag_grid(n)(1:3) =='UTT') where( maskU(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval - if (diag_grid(n)(1:3) =='TUT') where( maskV(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval - if (diag_grid(n)(1:3) =='TTU') where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + if (diag_grid(n)(1:3) =='TTT') where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + if (diag_grid(n)(1:3) =='UTT') where( maskU(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + if (diag_grid(n)(1:3) =='TUT') where( maskV(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + if (diag_grid(n)(1:3) =='TTU') where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,diag_name(n),id) iret= nf_put_vara_double(ncid,id,(/1,1,k,1/), (/nx,ny,1,1/),bloc) endif enddo - diag_sum_var3D(n)%a(:,:,:) = 0.0 + diag_sum_var3D(n)%a(:,:,:) = 0.0d0 else bloc(is_pe:ie_pe,js_pe:je_pe) = diag_sum_var2D(n)%a(is_pe:ie_pe,js_pe:je_pe)/nitts - if (diag_grid(n)(1:2) =='TT') where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval - if (diag_grid(n)(1:2) =='UT') where( maskU(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval - if (diag_grid(n)(1:2) =='TU') where( maskV(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + if (diag_grid(n)(1:2) =='TT') where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + if (diag_grid(n)(1:2) =='UT') where( maskU(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + if (diag_grid(n)(1:2) =='TU') where( maskV(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,diag_name(n),id) iret= nf_put_vara_double(ncid,id,(/1,1,1/), (/nx,ny,1/),bloc) endif - diag_sum_var2D(n)%a(:,:) = 0.0 + diag_sum_var2D(n)%a(:,:) = 0.0d0 endif enddo nitts = 0 @@ -226,7 +226,7 @@ subroutine diag_averages_read_restart if (ierr/=0) goto 10 open(io,file=filename,form='unformatted',status='old',err=10) read(io,err=10) nx_,ny_,nz_ - if (nx/=nx_ .or. ny/=ny_ .or. nz/= nz_) then + if (nx/=nx_ .or. ny/=ny_ .or. nz/= nz_) then if (my_pe==0) then print*,' read dimensions: ',nx_,ny_,nz_ print*,' does not match dimensions : ',nx,ny,nz @@ -254,7 +254,7 @@ subroutine diag_averages_read_restart endif do n=1,number_diags if (diag_is3D(n)) then - read(io,err=10) diag_sum_var3D(n)%a(:,:,:) + read(io,err=10) diag_sum_var3D(n)%a(:,:,:) else read(io,err=10) diag_sum_var2D(n)%a(:,:) endif @@ -293,7 +293,7 @@ subroutine diag_averages_write_restart write(io,err=10) nitts,number_diags do n=1,number_diags if (diag_is3D(n)) then - write(io,err=10) diag_sum_var3D(n)%a(is:ie,js:je,:) + write(io,err=10) diag_sum_var3D(n)%a(is:ie,js:je,:) else write(io,err=10) diag_sum_var2D(n)%a(is:ie,js:je) endif @@ -304,5 +304,3 @@ subroutine diag_averages_write_restart 10 continue print'(a)',' Warning: error writing file' end subroutine diag_averages_write_restart - - diff --git a/for_src/diagnostics/diag_energy.f90 b/for_src/diagnostics/diag_energy.f90 index 450064c..fca8472 100644 --- a/for_src/diagnostics/diag_energy.f90 +++ b/for_src/diagnostics/diag_energy.f90 @@ -22,11 +22,11 @@ subroutine diagnose_energy !======================================================================= ! Diagnose globally averaged energy cycle !======================================================================= - use main_module - use tke_module - use eke_module - use idemix_module - use isoneutral_module + use main_module + use tke_module + use eke_module + use idemix_module + use isoneutral_module use diag_energy_module implicit none integer :: i,j,k @@ -36,17 +36,17 @@ subroutine diagnose_energy real*8 :: NIWm,NIWforc,dNIWm,NIWdiss, M2m,M2forc,dM2m,M2diss,EKEdiss_tke,mdiss_skew,dPm_all !--------------------------------------------------------------------------------- - ! changes of dynamic enthalpy + ! changes of dynamic enthalpy !--------------------------------------------------------------------------------- - dPvmix=0; dPhmix=0; dPm=0.; dP_iso=0 - do k=1,nz + dPvmix=0; dPhmix=0; dPm=0.d0; dP_iso=0 + do k=1,nz do j=js_pe,je_pe do i=is_pe,ie_pe fxa = area_t(i,j)*dzt(k)*maskT(i,j,k) dP_iso = dP_iso + fxa*grav/rho_0*(-int_drhodT(i,j,k,tau)*dtemp_iso(i,j,k) -int_drhodS(i,j,k,tau)*dsalt_iso(i,j,k) ) dPhmix = dPhmix + fxa*grav/rho_0*(-int_drhodT(i,j,k,tau)*dtemp_hmix(i,j,k)-int_drhodS(i,j,k,tau)*dsalt_hmix(i,j,k) ) dPvmix = dPvmix + fxa*grav/rho_0*(-int_drhodT(i,j,k,taup1)*dtemp_vmix(i,j,k)-int_drhodS(i,j,k,taup1)*dsalt_vmix(i,j,k) ) - dPm = dPm + fxa*grav/rho_0*( & + dPm = dPm + fxa*grav/rho_0*( & -int_drhodT(i,j,k,tau)*dtemp(i,j,k,tau) -int_drhodS(i,j,k,tau)*dsalt(i,j,k,tau) )! this should be identical to g rho w enddo enddo @@ -57,12 +57,12 @@ subroutine diagnose_energy !--------------------------------------------------------------------------------- ! changes of kinetic energy !--------------------------------------------------------------------------------- - Km = 0; Pm = 0; dKm=0; spm=0.; corm=0.; KEadv=0.; - do k=1,nz + Km = 0; Pm = 0; dKm=0; spm=0.d0; corm=0.d0; KEadv=0.d0; + do k=1,nz do j=js_pe,je_pe do i=is_pe,ie_pe fxa = area_t(i,j)*dzt(k)*maskT(i,j,k) - Km = Km + fxa*0.5*( 0.5*(u(i,j,k,tau)**2+u(i-1,j,k,tau)**2) + 0.5*(v(i,j,k,tau)**2+v(i,j-1,k,tau)**2) ) + Km = Km + fxa*0.5d0*( 0.5d0*(u(i,j,k,tau)**2+u(i-1,j,k,tau)**2) + 0.5d0*(v(i,j,k,tau)**2+v(i,j-1,k,tau)**2) ) Pm = Pm + fxa*Hd(i,j,k,tau) ! grav/rho_0*rho(i,j,k,tau)*zt(k) dKm = dKm + u(i,j,k,tau)*du(i,j,k,tau)*area_u(i,j)*dzt(k) & +v(i,j,k,tau)*dv(i,j,k,tau)*area_v(i,j)*dzt(k) & @@ -70,8 +70,8 @@ subroutine diagnose_energy +v(i,j,k,tau)*dv_mix(i,j,k)*area_v(i,j)*dzt(k) corm = corm + u(i,j,k,tau)*du_cor(i,j,k)*area_u(i,j)*dzt(k) & + v(i,j,k,tau)*dv_cor(i,j,k)*area_v(i,j)*dzt(k) - KEadv = KEadv + u(i,j,k,tau)*du_adv(i,j,k)*area_u(i,j)*dzt(k)*maskU(i,j,k) & ! - + v(i,j,k,tau)*dv_adv(i,j,k)*area_v(i,j)*dzt(k)*maskV(i,j,k) ! + KEadv = KEadv + u(i,j,k,tau)*du_adv(i,j,k)*area_u(i,j)*dzt(k)*maskU(i,j,k) & ! + + v(i,j,k,tau)*dv_adv(i,j,k)*area_v(i,j)*dzt(k)*maskV(i,j,k) ! enddo enddo enddo @@ -80,7 +80,7 @@ subroutine diagnose_energy ! spurious work by surface pressure !--------------------------------------------------------------------------------- if (.not.enable_streamfunction) then - do k=1,nz + do k=1,nz do j=js_pe,je_pe do i=is_pe,ie_pe fxa = area_t(i,j)*dzt(k)*maskT(i,j,k) @@ -97,12 +97,12 @@ subroutine diagnose_energy ! K*Nsqr and KE and dyn. Enthalpy dissipation !--------------------------------------------------------------------------------- mdiss_gm=0; mdiss_v=0; mdiss_h=0; mdiss_vmix=0; mdiss_adv=0; mdiss_nonlin=0; mdiss_comp = 0; mdiss_hmix =0 - mdiss_iso=0; mdiss_sources = 0; mdiss_bot=0; mdiss_skew = 0.0 - do k=1,nz + mdiss_iso=0; mdiss_sources = 0; mdiss_bot=0; mdiss_skew = 0.0d0 + do k=1,nz do j=js_pe,je_pe do i=is_pe,ie_pe fxa = area_t(i,j)*dzw(k)*maskW(i,j,k) - if (k==nz) fxa=fxa*0.5 + if (k==nz) fxa=fxa*0.5d0 mdiss_vmix = mdiss_vmix + P_diss_v(i,j,k)*fxa mdiss_nonlin= mdiss_nonlin + P_diss_nonlin(i,j,k)*fxa mdiss_adv = mdiss_adv + P_diss_adv(i,j,k)*fxa @@ -121,7 +121,7 @@ subroutine diagnose_energy enddo call global_sum(mdiss_nonlin); call global_sum(mdiss_adv); call global_sum(mdiss_vmix) call global_sum(mdiss_h); call global_sum(mdiss_v); call global_sum(mdiss_gm) - call global_sum(mdiss_comp); call global_sum(mdiss_hmix); call global_sum(mdiss_iso); + call global_sum(mdiss_comp); call global_sum(mdiss_hmix); call global_sum(mdiss_iso); call global_sum(mdiss_sources); call global_sum(mdiss_bot); call global_sum(mdiss_skew) @@ -130,14 +130,14 @@ subroutine diagnose_energy !--------------------------------------------------------------------------------- wrhom=0 do j=js_pe,je_pe - do i=is_pe,ie_pe + do i=is_pe,ie_pe do k=1,nz-1 fxa = area_t(i,j)*maskW(i,j,k) wrhom = wrhom - fxa*(p_hydro(i,j,k+1)-p_hydro(i,j,k))*w(i,j,k,tau) enddo enddo enddo - call global_sum(wrhom); + call global_sum(wrhom); !--------------------------------------------------------------------------------- @@ -150,7 +150,7 @@ subroutine diagnose_energy wind = wind + v(i,j,nz,tau)*surface_tauy(i,j)*maskV(i,j,nz)*area_v(i,j) enddo enddo - call global_sum(wind); + call global_sum(wind); !--------------------------------------------------------------------------------- ! internal wave energy @@ -158,11 +158,11 @@ subroutine diagnose_energy Iwm=0; dIWm=0; IWdiss=0; IWforc=0 if (enable_idemix) then - do k=1,nz + do k=1,nz do j=js_pe,je_pe do i=is_pe,ie_pe fxa = area_t(i,j)*dzw(k)*maskW(i,j,k) - if (k==nz) fxa=fxa*0.5 + if (k==nz) fxa=fxa*0.5d0 IWm = IWm + fxa*E_iw(i,j,k,tau) dIWm = dIWm + fxa*(E_iw(i,j,k,taup1)-E_iw(i,j,k,tau))/dt_tracer IWdiss = IWdiss + fxa*iw_diss(i,j,k) @@ -176,7 +176,7 @@ subroutine diagnose_energy +forc_iw_bottom(i,j)*maskW(i,j,k)) enddo enddo - call global_sum(IWm); call global_sum(dIWm); call global_sum(IWdiss); call global_sum(IWforc); + call global_sum(IWm); call global_sum(dIWm); call global_sum(IWdiss); call global_sum(IWforc); endif !--------------------------------------------------------------------------------- @@ -195,7 +195,7 @@ subroutine diagnose_energy enddo enddo enddo - call global_sum(NIWm); call global_sum(dNIWm); call global_sum(NIWdiss); call global_sum(NIWforc); + call global_sum(NIWm); call global_sum(dNIWm); call global_sum(NIWdiss); call global_sum(NIWforc); endif !--------------------------------------------------------------------------------- @@ -214,7 +214,7 @@ subroutine diagnose_energy enddo enddo enddo - call global_sum(M2m); call global_sum(dM2m); call global_sum(M2diss); call global_sum(M2forc); + call global_sum(M2m); call global_sum(dM2m); call global_sum(M2diss); call global_sum(M2forc); endif !--------------------------------------------------------------------------------- @@ -222,11 +222,11 @@ subroutine diagnose_energy !--------------------------------------------------------------------------------- EKEm=0; dEKEm=0; EKEdiss=0; EKEdiss_tke=0 if (enable_eke) then - do k=1,nz + do k=1,nz do j=js_pe,je_pe do i=is_pe,ie_pe fxa = area_t(i,j)*dzw(k)*maskW(i,j,k) - if (k==nz) fxa=fxa*0.5 + if (k==nz) fxa=fxa*0.5d0 EKEm = EKEm + fxa*eke(i,j,k,tau) dEKEm = dEKEm + fxa*(eke(i,j,k,taup1)-eke(i,j,k,tau))/dt_tracer EKEdiss = EKEdiss + fxa*eke_diss_iw(i,j,k) @@ -234,7 +234,7 @@ subroutine diagnose_energy enddo enddo enddo - call global_sum(EKEm); call global_sum(dEKEm); call global_sum(EKEdiss); call global_sum(EKEdiss_tke); + call global_sum(EKEm); call global_sum(dEKEm); call global_sum(EKEdiss); call global_sum(EKEdiss_tke); endif !--------------------------------------------------------------------------------- @@ -242,25 +242,25 @@ subroutine diagnose_energy !--------------------------------------------------------------------------------- TKEm=0; dTKEm=0; TKEdiss=0; TKEforc=0 if (enable_tke) then - do k=1,nz + do k=1,nz do j=js_pe,je_pe do i=is_pe,ie_pe fxa = area_t(i,j)*dzw(k)*maskW(i,j,k) - if (k==nz) fxa=fxa*0.5 + if (k==nz) fxa=fxa*0.5d0 TKEm = TKEm + fxa*tke(i,j,k,tau) dTKEm = dTKEm + fxa*(tke(i,j,k,taup1)-tke(i,j,k,tau))/dt_tke TKEdiss = TKEdiss + fxa*tke_diss(i,j,k) enddo enddo enddo - call global_sum(TKEm); call global_sum(dTKEm); call global_sum(TKEdiss); + call global_sum(TKEm); call global_sum(dTKEm); call global_sum(TKEdiss); do j=js_pe,je_pe do i=is_pe,ie_pe fxa = area_t(i,j)*maskW(i,j,nz) TKEforc=TKEforc + fxa*(forc_tke_surface(i,j)+tke_surf_corr(i,j)) enddo enddo - call global_sum(TKEforc); + call global_sum(TKEforc); endif !--------------------------------------------------------------------------------- @@ -271,7 +271,7 @@ subroutine diagnose_energy if (.not.enable_store_cabbeling_heat) EKEdiss = EKEdiss - mdiss_hmix - mdiss_iso endif if (.not. enable_idemix) IWdiss = EKEdiss ! short cut for IW model - + nitts = nitts + 1 mean_e(1:7) = mean_e(1:7) + (/Km,Pm,EKEm,IWm,TKEm,NIWm,M2m/) mean_dedt(1:7) = mean_dedt(1:7) + (/dKm,dPm_all+mdiss_sources,dEKEm,dIWm,dTKEm,dNIWm,dM2m/) @@ -287,7 +287,7 @@ subroutine diagnose_energy mean_exchg(3) = mean_exchg(3) - mdiss_skew ! Hd -> EKE mean_exchg(4) = mean_exchg(4) + mdiss_v ! Ke -> TKE mean_exchg(5) = mean_exchg(5) - mdiss_vmix-mdiss_adv ! TKE-> Hd - if (enable_store_bottom_friction_tke) then + if (enable_store_bottom_friction_tke) then mean_exchg(4) = mean_exchg(4) + mdiss_bot ! Ke -> TKE else mean_exchg(6) = mean_exchg(6) + mdiss_bot ! KE -> IW @@ -307,7 +307,7 @@ subroutine diagnose_energy mean_misc(8) = mean_misc(8) + EKEdiss_tke mean_misc(9) = mean_misc(9) + mdiss_hmix + mdiss_iso - mean_misc(20) = mean_misc(20) + mdiss_h + mean_misc(20) = mean_misc(20) + mdiss_h mean_misc(21) = mean_misc(21) + mdiss_gm end subroutine diagnose_energy @@ -317,11 +317,11 @@ subroutine write_energy !======================================================================= ! write energy diagnostics to standard out and to netcdf file !======================================================================= - use main_module - use eke_module - use tke_module - use idemix_module - use isoneutral_module + use main_module + use eke_module + use tke_module + use idemix_module + use isoneutral_module use diagnostics_module use diag_energy_module implicit none @@ -339,14 +339,14 @@ subroutine write_energy if (my_pe==0) then fxa = rho_0/1d15 - print'(/,a,f12.2)',' Energy content averaged to day ',itt*dt_tracer/86400.0 - print'(a,f12.3,a)',' kin. energy ',mean_e(1)*fxa,' PetaJ ' - print'(a,f12.3,a)',' dyn. enthalpy',mean_e(2)*rho_0/1d21,' ZettaJ ' - print'(a,f12.3,a)',' eddy energy ',mean_e(3)*fxa,' PetaJ ' - print'(a,f12.3,a)',' IW. energy ',mean_e(4)*fxa,' PetaJ ' - if (enable_idemix .and. enable_idemix_niw) print'(a,f12.3,a)',' NIW. energy ',mean_e(6)*fxa,' PetaJ ' - if (enable_idemix .and. enable_idemix_M2) print'(a,f12.3,a)',' M2 tidal en. ',mean_e(7)*fxa,' PetaJ ' - print'(a,f12.3,a)',' tur. energy ',mean_e(5)*fxa,' PetaJ ' + print'(/,a,f12.2)',' Energy content averaged to day ',itt*dt_tracer/86400.0d0 + print'(a,f12.3,a)',' kin. energy ',mean_e(1)*fxa,' PetaJ ' + print'(a,f12.3,a)',' dyn. enthalpy',mean_e(2)*rho_0/1d21,' ZettaJ ' + print'(a,f12.3,a)',' eddy energy ',mean_e(3)*fxa,' PetaJ ' + print'(a,f12.3,a)',' IW. energy ',mean_e(4)*fxa,' PetaJ ' + if (enable_idemix .and. enable_idemix_niw) print'(a,f12.3,a)',' NIW. energy ',mean_e(6)*fxa,' PetaJ ' + if (enable_idemix .and. enable_idemix_M2) print'(a,f12.3,a)',' M2 tidal en. ',mean_e(7)*fxa,' PetaJ ' + print'(a,f12.3,a)',' tur. energy ',mean_e(5)*fxa,' PetaJ ' print*,' ' fxa = rho_0/1d12 @@ -394,7 +394,7 @@ subroutine write_energy print'(a,e12.6,a)',' dissipation ',mean_diss(4)*fxa,' TW' print'(a,e12.6,a)',' EKE -> IW ',mean_exchg(8)*fxa,' TW' print'(a,e12.6,a)',' KE -> IW ',mean_exchg(6)*fxa,' TW' - fxb = mean_dedt(4)-mean_forc(4)+mean_diss(4)-mean_exchg(8)-mean_exchg(6) + fxb = mean_dedt(4)-mean_forc(4)+mean_diss(4)-mean_exchg(8)-mean_exchg(6) if (enable_idemix_niw) fxb = fxb - mean_diss(6) print'(a,e12.6,a)',' error ',fxb*fxa,' TW' print*,' ' @@ -455,9 +455,9 @@ subroutine write_energy iret=nf_inq_dimlen(ncid, timedim,i) i=i+1 iret=nf_inq_varid(ncid,'Time',id) - fxa = itt*dt_tracer/86400.0 + fxa = itt*dt_tracer/86400.0d0 iret= nf_put_vara_double(ncid,id,i,1,fxa) - + iret=nf_inq_varid(ncid,'KE',id); iret= nf_put_vara_double(ncid,id,i,1,mean_e(1)*rho_0) iret=nf_inq_varid(ncid,'Hd',id); iret= nf_put_vara_double(ncid,id,i,1,mean_e(2)*rho_0) iret=nf_inq_varid(ncid,'EKE',id); iret= nf_put_vara_double(ncid,id,i,1,mean_e(3)*rho_0) @@ -514,7 +514,7 @@ subroutine init_diag_energy !======================================================================= ! initialize NetCDF snapshot file !======================================================================= - use main_module + use main_module use diagnostics_module use diag_energy_module implicit none @@ -542,8 +542,8 @@ subroutine init_diag_energy Timedim = ncddef(ncid, 'Time', nf_unlimited, iret) timeid = ncvdef (ncid,'Time', NCFLOAT,1,timedim,iret) name = 'Time '; unit = 'days' - call ncaptc(ncid, timeid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, timeid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, timeid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, timeid, 'units', NCCHAR, 16, unit, iret) call ncaptc(ncid, Timeid,'time_origin',NCCHAR, 20,'01-JAN-1900 00:00:00', iret) ! Energies @@ -743,5 +743,3 @@ subroutine diag_energy_write_restart 10 continue print'(a)',' Warning: error writing file' end subroutine diag_energy_write_restart - - diff --git a/for_src/diagnostics/diag_main.f90 b/for_src/diagnostics/diag_main.f90 index 7363b63..d11ffab 100644 --- a/for_src/diagnostics/diag_main.f90 +++ b/for_src/diagnostics/diag_main.f90 @@ -6,8 +6,8 @@ subroutine init_diagnostics !======================================================================= ! initialize diagnostic routines !======================================================================= - use main_module - use diagnostics_module + use main_module + use diagnostics_module implicit none if (my_pe==0) print'(/,a)','Diagnostic setup:' @@ -60,9 +60,9 @@ subroutine diagnose !======================================================================= ! call diagnostic routines !======================================================================= - use main_module - use diagnostics_module - use isoneutral_module + use main_module + use diagnostics_module + use isoneutral_module implicit none logical :: GM_strfct_diagnosed real*8 :: time @@ -130,11 +130,11 @@ subroutine diag_cfl !======================================================================= ! check for CFL violation !======================================================================= - use main_module - use tke_module - use eke_module - use idemix_module - use diagnostics_module + use main_module + use tke_module + use eke_module + use idemix_module + use diagnostics_module implicit none integer :: i,j,k real*8 :: cfl,wcfl @@ -150,7 +150,7 @@ subroutine diag_cfl enddo enddo call global_max(cfl); call global_max(wcfl) - !if (cfl > 0.5.or.wcfl > 0.5) then + !if (cfl > 0.5d0.or.wcfl > 0.5d0) then ! if (my_pe==0) print'(/a,f12.6)','ERROR: maximal CFL number = ',max(cfl,wcfl) ! if (my_pe==0) print'(a,i9,a/)' ,' at itt = ',itt,' ... stopping integration ' ! if (.not. enable_diag_snapshots ) call init_snap_cdf @@ -195,14 +195,14 @@ subroutine diag_tracer_content !======================================================================= ! Diagnose tracer content !======================================================================= - use main_module + use main_module implicit none integer :: i,j,k real*8 :: fxa,tempm,saltm,volm,vtemp,vsalt - real*8, save :: tempm1=0.,saltm1=0.,vtemp1=0.,vsalt1=0. + real*8, save :: tempm1=0.d0,saltm1=0.d0,vtemp1=0.d0,vsalt1=0.d0 volm=0;tempm=0;vtemp=0;saltm=0;vsalt=0 - do k=1,nz + do k=1,nz do j=js_pe,je_pe do i=is_pe,ie_pe fxa = area_t(i,j)*dzt(k)*maskT(i,j,k) @@ -214,8 +214,8 @@ subroutine diag_tracer_content enddo enddo enddo - call global_sum(tempm); call global_sum(saltm); call global_sum(volm); - call global_sum(vtemp); call global_sum(vsalt); + call global_sum(tempm); call global_sum(saltm); call global_sum(volm); + call global_sum(vtemp); call global_sum(vsalt); if (my_pe==0) then print*,' ' @@ -227,5 +227,3 @@ subroutine diag_tracer_content tempm1=tempm; vtemp1=vtemp; saltm1=saltm; vsalt1=vsalt end subroutine diag_tracer_content - - diff --git a/for_src/diagnostics/diag_over.f90 b/for_src/diagnostics/diag_over.f90 index d8c4233..0c0250b 100644 --- a/for_src/diagnostics/diag_over.f90 +++ b/for_src/diagnostics/diag_over.f90 @@ -7,7 +7,7 @@ module module_diag_overturning !======================================================================= implicit none integer :: nitts - integer :: nlevel + integer :: nlevel real*8,allocatable :: sig(:),zarea(:,:) character (len=80) :: over_file real*8 :: p_ref = 0d0 ! in dbar @@ -50,17 +50,17 @@ subroutine init_diag_overturning endif ! sigma levels - p_ref=2000.0 + p_ref=2000.0d0 sige = get_rho(35d0,-2d0,p_ref) sigs = get_rho(35d0,30d0,p_ref) - dsig = (sige-sigs)/(nlevel-1.) + dsig = (sige-sigs)/(nlevel-1.d0) if (my_pe==0) then - print'(a)', ' sigma ranges for overturning diagnostic:' + print'(a)', ' sigma ranges for overturning diagnostic:' print'(a,f12.6)',' start sigma0 = ',sigs print'(a,f12.6)',' end sigma0 = ',sige print'(a,f12.6)',' Delta sigma0 = ',dsig if (enable_neutral_diffusion .and. enable_skew_diffusion) & - print'(a)', ' also calculating overturning by eddy-driven velocities' + print'(a)', ' also calculating overturning by eddy-driven velocities' endif do k=1,nlevel sig(k) = sigs + dsig*(k-1) @@ -85,25 +85,25 @@ subroutine init_diag_overturning iTimedim = ncddef(ncid, 'Time', nf_unlimited, iret) itimeid = ncvdef (ncid,'Time', NCFLOAT,1,itimedim,iret) name = 'Time '; unit = 'days' - call ncaptc(ncid, itimeid, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, itimeid, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, itimeid, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, itimeid, 'units', NCCHAR, len_trim(unit), unit, iret) call ncaptc(ncid, iTimeid,'time_origin',NCCHAR, 20,'01-JAN-1900 00:00:00', iret) sig_dim = ncddef(ncid, 'sigma', nlevel , iret) sig_id = ncvdef (ncid,'sigma',NCFLOAT,1,sig_dim,iret) name = 'Sigma axis'; unit = 'kg/m^3' - call ncaptc(ncid, sig_id, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, sig_id, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, sig_id, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, sig_id, 'units', NCCHAR, len_trim(unit), unit, iret) z_tdim = ncddef(ncid, 'zt', nz, iret) z_udim = ncddef(ncid, 'zu', nz, iret) z_tid = ncvdef (ncid,'zt', NCFLOAT,1,z_tdim,iret) z_uid = ncvdef (ncid,'zu', NCFLOAT,1,z_udim,iret) name = 'Height on T grid '; unit = 'm' - call ncaptc(ncid, z_tid, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, z_tid, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, z_tid, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, z_tid, 'units', NCCHAR, len_trim(unit), unit, iret) name = 'Height on U grid '; unit = 'm' - call ncaptc(ncid, z_uid, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, z_uid, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, z_uid, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, z_uid, 'units', NCCHAR, len_trim(unit), unit, iret) Lat_udim = ncddef(ncid,'yu', ny , iret) @@ -112,54 +112,54 @@ subroutine init_diag_overturning Lat_tid = ncvdef (ncid,'yt',NCFLOAT,1,lat_udim,iret) if (coord_degree) then name = 'Latitude on T grid '; unit = 'degrees N' - call ncaptc(ncid, Lat_tid, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, Lat_tid, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, Lat_tid, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, Lat_tid, 'units', NCCHAR, len_trim(unit), unit, iret) name = 'Latitude on U grid '; unit = 'degrees N' - call ncaptc(ncid, Lat_uid, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, Lat_uid, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, Lat_uid, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, Lat_uid, 'units', NCCHAR, len_trim(unit), unit, iret) else name = 'meridional axis T grid'; unit = 'km' - call ncaptc(ncid, Lat_tid, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, Lat_tid, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, Lat_tid, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, Lat_tid, 'units', NCCHAR, len_trim(unit), unit, iret) name = 'meridional axis U grid'; unit = 'km' - call ncaptc(ncid, Lat_uid, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, Lat_uid, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, Lat_uid, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, Lat_uid, 'units', NCCHAR, len_trim(unit), unit, iret) endif id = ncvdef (ncid,'trans',NCFLOAT,3,(/lat_udim,sig_dim,itimedim/),iret) name = 'Meridional transport'; unit = 'm^3/s' - call ncaptc(ncid, id, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, id, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, id, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, id, 'units', NCCHAR, len_trim(unit), unit, iret) call ncapt (ncid,id, 'missing_value',NCDOUBLE,1,-1d33,iret) call ncapt (ncid,id, '_FillValue', NCDOUBLE, 1,-1d33, iret) id = ncvdef (ncid,'vsf_iso',NCFLOAT,3,(/lat_udim,z_udim,itimedim/),iret) name = 'Meridional transport'; unit = 'm^3/s' - call ncaptc(ncid, id, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, id, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, id, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, id, 'units', NCCHAR, len_trim(unit), unit, iret) call ncapt (ncid,id, 'missing_value',NCDOUBLE,1,-1d33,iret) call ncapt (ncid,id, '_FillValue', NCDOUBLE, 1,-1d33, iret) id = ncvdef (ncid,'vsf_depth',NCFLOAT,3,(/lat_udim,z_udim,itimedim/),iret) name = 'Meridional transport'; unit = 'm^3/s' - call ncaptc(ncid, id, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, id, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, id, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, id, 'units', NCCHAR, len_trim(unit), unit, iret) call ncapt (ncid,id, 'missing_value',NCDOUBLE,1,-1d33,iret) call ncapt (ncid,id, '_FillValue', NCDOUBLE, 1,-1d33, iret) if (enable_neutral_diffusion .and. enable_skew_diffusion) then id = ncvdef (ncid,'bolus_iso',NCFLOAT,3,(/lat_udim,z_udim,itimedim/),iret) name = 'Meridional transport'; unit = 'm^3/s' - call ncaptc(ncid, id, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, id, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, id, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, id, 'units', NCCHAR, len_trim(unit), unit, iret) call ncapt (ncid,id, 'missing_value',NCDOUBLE,1,-1d33,iret) call ncapt (ncid,id, '_FillValue', NCDOUBLE, 1,-1d33, iret) id = ncvdef (ncid,'bolus_depth',NCFLOAT,3,(/lat_udim,z_udim,itimedim/),iret) name = 'Meridional transport'; unit = 'm^3/s' - call ncaptc(ncid, id, 'long_name', NCCHAR, len_trim(name), name, iret) - call ncaptc(ncid, id, 'units', NCCHAR, len_trim(unit), unit, iret) + call ncaptc(ncid, id, 'long_name', NCCHAR, len_trim(name), name, iret) + call ncaptc(ncid, id, 'units', NCCHAR, len_trim(unit), unit, iret) call ncapt (ncid,id, 'missing_value',NCDOUBLE,1,-1d33,iret) call ncapt (ncid,id, '_FillValue', NCDOUBLE, 1,-1d33, iret) endif @@ -183,8 +183,8 @@ subroutine init_diag_overturning iret= nf_put_vara_double(ncid,lat_Tid,js_pe,je_pe-js_pe+1 ,yt(js_pe:je_pe)) iret= nf_put_vara_double(ncid,lat_uid,js_pe,je_pe-js_pe+1 ,yu(js_pe:je_pe)) else - iret= nf_put_vara_double(ncid,lat_Tid,js_pe,je_pe-js_pe+1 ,yt(js_pe:je_pe)/1e3) - iret= nf_put_vara_double(ncid,lat_uid,js_pe,je_pe-js_pe+1 ,yu(js_pe:je_pe)/1e3) + iret= nf_put_vara_double(ncid,lat_Tid,js_pe,je_pe-js_pe+1 ,yt(js_pe:je_pe)/1d3) + iret= nf_put_vara_double(ncid,lat_uid,js_pe,je_pe-js_pe+1 ,yu(js_pe:je_pe)/1d3) endif iret=nf_close(ncid) endif @@ -201,7 +201,7 @@ subroutine diag_overturning integer :: i,j,k,m,m1,m2,mm,mmp,mmm real*8 :: get_rho real*8 :: trans(js_pe-onx:je_pe+onx,nlevel),fxa - real*8 :: z_sig(js_pe-onx:je_pe+onx,nlevel) + real*8 :: z_sig(js_pe-onx:je_pe+onx,nlevel) real*8 :: bolus_trans(js_pe-onx:je_pe+onx,nlevel) real*8 :: bolus_iso(js_pe-onx:je_pe+onx,nz) real*8 :: vsf_iso(js_pe-onx:je_pe+onx,nz) @@ -224,14 +224,14 @@ subroutine diag_overturning do m=1,nlevel do k=1,nz do i=is_pe,ie_pe - fxa = 0.5*( sig_loc(i,j,k) + sig_loc(i,j+1,k)) - if (fxa > sig(m) ) then + fxa = 0.5d0*( sig_loc(i,j,k) + sig_loc(i,j+1,k)) + if (fxa > sig(m) ) then trans(j,m) = trans(j,m) + v(i,j,k,tau)*dxt(i)*cosu(j)*dzt(k)*maskV(i,j,k) z_sig(j,m) = z_sig(j,m) + dzt(k)*dxt(i)*cosu(j)*maskV(i,j,k) endif enddo enddo - enddo + enddo enddo call zonal_sum_vec(trans(js_pe:je_pe,:),nlevel*(je_pe-js_pe+1)) call zonal_sum_vec(z_sig(js_pe:je_pe,:),nlevel*(je_pe-js_pe+1)) @@ -243,16 +243,16 @@ subroutine diag_overturning do m=1,nlevel k=1 do i=is_pe,ie_pe - fxa = 0.5*( sig_loc(i,j,k) + sig_loc(i,j+1,k)) + fxa = 0.5d0*( sig_loc(i,j,k) + sig_loc(i,j+1,k)) if (fxa > sig(m) ) bolus_trans(j,m) = bolus_trans(j,m) + b1_gm(i,j,k)*dxt(i)*cosu(j)*maskV(i,j,k) enddo do k=2,nz do i=is_pe,ie_pe - fxa = 0.5*( sig_loc(i,j,k) + sig_loc(i,j+1,k)) + fxa = 0.5d0*( sig_loc(i,j,k) + sig_loc(i,j+1,k)) if (fxa > sig(m) ) bolus_trans(j,m) = bolus_trans(j,m) + (b1_gm(i,j,k)-b1_gm(i,j,k-1))*dxt(i)*cosu(j)*maskV(i,j,k) enddo enddo - enddo + enddo enddo call zonal_sum_vec(bolus_trans(js_pe:je_pe,:),nlevel*(je_pe-js_pe+1)) endif @@ -265,8 +265,8 @@ subroutine diag_overturning enddo do k=2,nz vsf_depth(j,k) = vsf_depth(j,k-1) + vsf_depth(j,k)*dzt(k) - enddo - enddo + enddo + enddo call zonal_sum_vec(vsf_depth(js_pe:je_pe,:),nz*(je_pe-js_pe+1)) if (enable_neutral_diffusion .and. enable_skew_diffusion) then @@ -298,7 +298,7 @@ subroutine diag_overturning m1=mm; m2=mmp elseif (z_sig(j,mm)= zarea(j,k) ) then m1=mm; m2=mmm - else + else m1=mm;m2=mm endif @@ -306,20 +306,20 @@ subroutine diag_overturning if (fxa /=0d0) then if (zarea(j,k)-z_sig(j,m1) > z_sig(j,m2)-zarea(j,k) ) then fxa = (zarea(j,k)-z_sig(j,m1))/fxa - vsf_iso(j,k)=trans(j,m1)*(1-fxa) + trans(j,m2)*fxa + vsf_iso(j,k)=trans(j,m1)*(1-fxa) + trans(j,m2)*fxa bolus_iso(j,k)=bolus_trans(j,m1)*(1-fxa) + bolus_trans(j,m2)*fxa ! to save time else fxa = (z_sig(j,m2)-zarea(j,k))/fxa - vsf_iso(j,k)=trans(j,m1)*fxa + trans(j,m2)*(1-fxa) + vsf_iso(j,k)=trans(j,m1)*fxa + trans(j,m2)*(1-fxa) bolus_iso(j,k)=bolus_trans(j,m1)*fxa + bolus_trans(j,m2)*(1-fxa) endif else - vsf_iso(j,k)=trans(j,m1) - bolus_iso(j,k)=bolus_trans(j,m1) + vsf_iso(j,k)=trans(j,m1) + bolus_iso(j,k)=bolus_trans(j,m1) endif enddo enddo - + endif ! average in time @@ -351,7 +351,7 @@ subroutine write_overturning iret=nf_inq_dimid(ncid,'Time',itdimid) iret=nf_inq_dimlen(ncid, itdimid,ilen) ilen=ilen+1 - fxa = itt*dt_tracer/86400.0 + fxa = itt*dt_tracer/86400.0d0 iret=nf_inq_varid(ncid,'Time',itimeid) iret= nf_put_vara_double(ncid,itimeid,ilen,1,fxa) iret=nf_close(ncid) @@ -415,7 +415,7 @@ subroutine diag_over_read_restart integer :: io,ierr,ny_,nz_,nl_,js_,je_ if (my_blk_i>1) return ! no need to read anything - + write(filename,'(a,i5,a)') 'unfinished_over_PE_',my_pe,'.dta' call replace_space_zero(filename) inquire ( FILE=filename, EXIST=file_exists ) @@ -432,7 +432,7 @@ subroutine diag_over_read_restart if (ierr/=0) goto 10 open(io,file=filename,form='unformatted',status='old',err=10) read(io,err=10) nitts,ny_,nz_,nl_ - if (ny/=ny_ .or. nz/= nz_ .or. nl_ /=nlevel) then + if (ny/=ny_ .or. nz/= nz_ .or. nl_ /=nlevel) then if (my_pe==0) then print*,' read dimensions: ',ny_,nz_,nl_ print*,' does not match dimensions : ',ny,nz,nlevel @@ -492,5 +492,3 @@ subroutine diag_over_write_restart 10 continue print'(a)',' Warning: error writing file' end subroutine diag_over_write_restart - - diff --git a/for_src/diagnostics/diag_particles.f90 b/for_src/diagnostics/diag_particles.f90 index b382a1e..ac5e6da 100644 --- a/for_src/diagnostics/diag_particles.f90 +++ b/for_src/diagnostics/diag_particles.f90 @@ -4,7 +4,7 @@ module particles_module !======================================================================= ! module for particles !======================================================================= - implicit none + implicit none integer :: mmax ! fraction of time step for integration integer :: nptraj=-1 ! number of particles real*8, allocatable :: pxyz(:,:) ! position of particles @@ -23,14 +23,14 @@ subroutine allocate_particles(n_in) !======================================================================= use main_module use particles_module - implicit none + implicit none integer, intent(in) :: n_in mmax = 1 nptraj = n_in allocate( pijk(3,nptraj) ); pijk=0 - allocate( pxyz(3,nptraj) ); pxyz=0.0 - allocate( puvw(3,nptraj) ); puvw=0.0 - allocate( pts(2,nptraj) ); pts=0.0 + allocate( pxyz(3,nptraj) ); pxyz=0.0d0 + allocate( puvw(3,nptraj) ); puvw=0.0d0 + allocate( pts(2,nptraj) ); pts=0.0d0 allocate( particle_active( nptraj) ); particle_active = .false. allocate( particle_pe( nptraj) ); particle_pe=-1 end subroutine allocate_particles @@ -44,10 +44,10 @@ subroutine init_diag_particles !======================================================================= use main_module use particles_module - implicit none + implicit none integer :: i,n - lenx_periodic = 0.0 + lenx_periodic = 0.0d0 do i=is_pe,ie_pe lenx_periodic = lenx_periodic + dxt(i) enddo @@ -73,11 +73,11 @@ subroutine particle_pe_domain() !======================================================================= use main_module use particles_module - implicit none + implicit none integer :: n do n=1,nptraj if (pijk(1,n)>=is_pe .and. pijk(1,n)<=ie_pe .and. pijk(2,n)>=js_pe .and. pijk(2,n)<=je_pe ) then - particle_active(n) = .true. + particle_active(n) = .true. particle_pe(n)=my_pe else particle_active(n) = .false. @@ -94,7 +94,7 @@ subroutine particle_distribute !======================================================================= use main_module use particles_module - implicit none + implicit none integer :: n do n=1,nptraj if (particle_pe(n)>=0) then @@ -118,7 +118,7 @@ subroutine integrate_particles !======================================================================= use main_module use particles_module - implicit none + implicit none integer :: i,j,k,n,m real*8 :: xe,xw,yn,ys,zu,zl,dvol,th,tf real*8 :: xeyszu,xeyszl,xeynzu,xeynzl @@ -127,7 +127,7 @@ subroutine integrate_particles real*8 :: uuf,vvf,wwf,uu,vv,ww,rcos,fac - fac = 1.0 + fac = 1.0d0 if (coord_degree) fac = mtodeg @@ -136,13 +136,13 @@ subroutine integrate_particles call particle_pe_domain() do n=1,nptraj - th= (m-1.)/mmax; tf = 1.-th; + th= (m-1.d0)/mmax; tf = 1.d0-th; if (particle_active(n)) then !----------------------------------------------------------------------- ! interpolate T/S on particle position !----------------------------------------------------------------------- - i = pijk(1,n); + i = pijk(1,n); if (pxyz(1,n) > xt(i) ) then i=i+1 xe = (xt(i-1)+dxu(i)*fac - pxyz(1,n)); xw = (pxyz(1,n)-xt(i-1)) @@ -160,9 +160,9 @@ subroutine integrate_particles k=nz zu=0;zl=dzt(k) elseif (k<=1) then - k=2 + k=2 zu=dzt(k);zl=0 - else + else zu = (zt(k) - pxyz(3,n)); zl = (pxyz(3,n)-zt(k-1)) if (maskT(i,j,k-1)==0) then; zu=0;zl=dzt(k); endif endif @@ -172,7 +172,7 @@ subroutine integrate_particles if (maskT(i,j+1,k)==0) then; yn=dyt(j)*fac;ys=0; endif if (maskT(i,j-1,k)==0) then; yn=0;ys=dyt(j)*fac; endif - dvol = 1./(dxu(i)*dyt(j)*dzt(k)*fac**2) + dvol = 1.d0/(dxu(i)*dyt(j)*dzt(k)*fac**2) xeyszu = xe*ys*zu*dvol; xwyszu = xw*ys*zu*dvol xeyszl = xe*ys*zl*dvol; xwyszl = xw*ys*zl*dvol xeynzu = xe*yn*zu*dvol; xwynzu = xw*yn*zu*dvol @@ -185,7 +185,7 @@ subroutine integrate_particles ttf=temp(i-1,j ,k-1,taup1)*xeyszu+temp(i,j ,k-1,taup1)*xwyszu & +temp(i-1,j ,k ,taup1)*xeyszl+temp(i,j ,k ,taup1)*xwyszl & +temp(i-1,j-1,k-1,taup1)*xeynzu+temp(i,j-1,k-1,taup1)*xwynzu & - +temp(i-1,j-1,k ,taup1)*xeynzl+temp(i,j-1,k ,taup1)*xwynzl + +temp(i-1,j-1,k ,taup1)*xeynzl+temp(i,j-1,k ,taup1)*xwynzl pts(1,n)=th*tth+tf*ttf tth=salt(i-1,j ,k-1,tau )*xeyszu+salt(i,j ,k-1,tau )*xwyszu & @@ -195,11 +195,11 @@ subroutine integrate_particles ttf=salt(i-1,j ,k-1,taup1)*xeyszu+salt(i,j ,k-1,taup1)*xwyszu & +salt(i-1,j ,k ,taup1)*xeyszl+salt(i,j ,k ,taup1)*xwyszl & +salt(i-1,j-1,k-1,taup1)*xeynzu+salt(i,j-1,k-1,taup1)*xwynzu & - +salt(i-1,j-1,k ,taup1)*xeynzl+salt(i,j-1,k ,taup1)*xwynzl + +salt(i-1,j-1,k ,taup1)*xeynzl+salt(i,j-1,k ,taup1)*xwynzl pts(2,n)=th*tth+tf*ttf !----------------------------------------------------------------------- -! pijk gives tracer box of the particle, +! pijk gives tracer box of the particle, ! find u-box and distances to borders, account for free slip !----------------------------------------------------------------------- i = pijk(1,n); @@ -215,9 +215,9 @@ subroutine integrate_particles k=nz zu=0;zl=dzt(k) elseif (k<=1) then - k=2 + k=2 zu=dzt(k);zl=0 - else + else zu = (zt(k) - pxyz(3,n)); zl = (pxyz(3,n)-zt(k-1)) if (maskT(i,j,k-1)==0) then; zu=0;zl=dzt(k); endif endif @@ -225,7 +225,7 @@ subroutine integrate_particles if (maskT(i,j+1,k)==0) then; yn=dyt(j)*fac;ys=0; endif if (maskT(i,j-1,k)==0) then; yn=0;ys=dyt(j)*fac; endif - dvol = 1./(dxu(i)*dyt(j)*dzt(k)*fac**2) + dvol = 1.d0/(dxu(i)*dyt(j)*dzt(k)*fac**2) xeyszu = xe*ys*zu*dvol; xwyszu = xw*ys*zu*dvol xeyszl = xe*ys*zl*dvol; xwyszl = xw*ys*zl*dvol xeynzu = xe*yn*zu*dvol; xwynzu = xw*yn*zu*dvol @@ -240,12 +240,12 @@ subroutine integrate_particles uuf=u(i-1,j ,k-1,taup1)*xeyszu+u(i,j ,k-1,taup1)*xwyszu & +u(i-1,j ,k ,taup1)*xeyszl+u(i,j ,k ,taup1)*xwyszl & +u(i-1,j-1,k-1,taup1)*xeynzu+u(i,j-1,k-1,taup1)*xwynzu & - +u(i-1,j-1,k ,taup1)*xeynzl+u(i,j-1,k ,taup1)*xwynzl + +u(i-1,j-1,k ,taup1)*xeynzl+u(i,j-1,k ,taup1)*xwynzl uu=th*uuh+tf*uuf !----------------------------------------------------------------------- ! find v-box and distances to borders, account for free slip !----------------------------------------------------------------------- - i = pijk(1,n); + i = pijk(1,n); if (pxyz(1,n) > xt(i) ) then i=i+1 xe = (xt(i-1)+dxu(i)*fac - pxyz(1,n)); xw = (pxyz(1,n)-xt(i-1)) @@ -262,9 +262,9 @@ subroutine integrate_particles k=nz zu=0;zl=dzt(k) elseif (k<=1) then - k=2 + k=2 zu=dzt(k);zl=0 - else + else zu = (zt(k) - pxyz(3,n)); zl = (pxyz(3,n)-zt(k-1)) if (maskT(i,j, k-1)==0) then; zu=0;zl=dzt(k); endif endif @@ -272,7 +272,7 @@ subroutine integrate_particles if (maskT(i+1,j,k)==0) then; xe=dxt(i)*fac;xw=0; endif if (maskT(i-1,j,k)==0) then; xe=0;xw=dxt(i)*fac; endif - dvol = 1./(dxt(i)*fac*dyu(j)*fac*dzt(k)) + dvol = 1.d0/(dxt(i)*fac*dyu(j)*fac*dzt(k)) xeyszu = xe*ys*zu*dvol; xwyszu = xw*ys*zu*dvol xeyszl = xe*ys*zl*dvol; xwyszl = xw*ys*zl*dvol xeynzu = xe*yn*zu*dvol; xwynzu = xw*yn*zu*dvol @@ -292,7 +292,7 @@ subroutine integrate_particles !----------------------------------------------------------------------- ! find w-box and distances to borders, account for free slip !----------------------------------------------------------------------- - i = pijk(1,n); + i = pijk(1,n); if (pxyz(1,n) > xt(i) ) then i=i+1 xe = (xt(i-1)+dxu(i)*fac - pxyz(1,n)); xw = (pxyz(1,n)-xt(i-1)) @@ -300,15 +300,15 @@ subroutine integrate_particles xe = (xt(i) - pxyz(1,n)); xw = (pxyz(1,n)-(xt(i)-dxu(i-1)*fac) ) endif - j = pijk(2,n); + j = pijk(2,n); if (pxyz(2,n) > yt(j) ) j=j+1 yn = (yt(j) - pxyz(2,n)); ys = (pxyz(2,n) - yt(j-1)) k = pijk(3,n) if (k<=1) then - k=2 + k=2 zu=dzw(k);zl=0 - else + else zu = (zw(k) - pxyz(3,n)); zl = (pxyz(3,n)-zw(k-1)) endif @@ -317,7 +317,7 @@ subroutine integrate_particles if (maskT(i,j+1,k)==0) then; yn=dyt(j)*fac;ys=0; endif if (maskT(i,j-1,k)==0) then; yn=0;ys=dyt(j)*fac; endif - dvol = 1./(dxt(i)*fac*dyt(j)*fac*dzw(k)) + dvol = 1.d0/(dxt(i)*fac*dyt(j)*fac*dzw(k)) xeyszu = xe*ys*zu*dvol; xwyszu = xw*ys*zu*dvol xeyszl = xe*ys*zl*dvol; xwyszl = xw*ys*zl*dvol xeynzu = xe*yn*zu*dvol; xwynzu = xw*yn*zu*dvol @@ -343,12 +343,12 @@ subroutine integrate_particles !----------------------------------------------------------------------- xold=pxyz(1,n); yold=pxyz(2,n); zold=pxyz(3,n) if (coord_degree) then - rcos = mtodeg/cos(pxyz(2,n)/180.*pi) + rcos = mtodeg/cos(pxyz(2,n)/180.d0*pi) pxyz(1,n) = pxyz(1,n) + dt_tracer*uu/mmax *rcos pxyz(2,n) = pxyz(2,n) + dt_tracer*vv/mmax *mtodeg pxyz(3,n) = pxyz(3,n) + dt_tracer*ww/mmax else - pxyz(1,n) = pxyz(1,n) + dt_tracer*uu/mmax + pxyz(1,n) = pxyz(1,n) + dt_tracer*uu/mmax pxyz(2,n) = pxyz(2,n) + dt_tracer*vv/mmax pxyz(3,n) = pxyz(3,n) + dt_tracer*ww/mmax endif @@ -375,7 +375,7 @@ subroutine integrate_particles if ( k>1) then if (pxyz(3,n) < zw(k-1) ) pijk(3,n) = k - 1 endif - + !----------------------------------------------------------------------- ! periodic boundary conditions !----------------------------------------------------------------------- @@ -406,7 +406,7 @@ subroutine particles_read_restart character (len=80) :: filename logical :: file_exists integer :: io,ierr,nptraj_ - + write(filename,'(a,i5,a)') 'particles_restart.dta' inquire ( FILE=filename, EXIST=file_exists ) if (.not. file_exists) then @@ -461,6 +461,3 @@ subroutine particles_write_restart 10 continue print'(a)',' Warning: error writing file' end subroutine particles_write_restart - - - diff --git a/for_src/diagnostics/diag_particles_netcdf.f90 b/for_src/diagnostics/diag_particles_netcdf.f90 index 286e4e7..eba1fb8 100644 --- a/for_src/diagnostics/diag_particles_netcdf.f90 +++ b/for_src/diagnostics/diag_particles_netcdf.f90 @@ -11,7 +11,7 @@ subroutine init_write_particles !======================================================================= use main_module use particles_module - implicit none + implicit none include "netcdf.inc" integer :: ncid,tdim,pdim,tid,xid,yid,zid,iret,vid character :: name*24, unit*16 @@ -25,8 +25,8 @@ subroutine init_write_particles xid = ncvdef (ncid,'x_pos', NCFLOAT,2,(/pdim,tdim/),iret) yid = ncvdef (ncid,'y_pos', NCFLOAT,2,(/pdim,tdim/),iret) zid = ncvdef (ncid,'z_pos', NCFLOAT,2,(/pdim,tdim/),iret) - call ncaptc(ncid, tid, 'long_name', NCCHAR, 4, 'Time', iret) - call ncaptc(ncid, tid, 'units', NCCHAR, 4, 'days', iret) + call ncaptc(ncid, tid, 'long_name', NCCHAR, 4, 'Time', iret) + call ncaptc(ncid, tid, 'units', NCCHAR, 4, 'days', iret) call ncaptc(ncid, Tid,'time_origin',NCCHAR, 20,'01-JAN-1900 00:00:00', iret) if (coord_degree) then @@ -34,45 +34,45 @@ subroutine init_write_particles else name = 'zonal position'; unit = 'km' endif - call ncaptc(ncid, xid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, xid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, xid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, xid, 'units', NCCHAR, 16, unit, iret) if (coord_degree) then name = 'Latitude'; unit = 'degrees N' else name = 'meridional position'; unit = 'km' endif - call ncaptc(ncid, yid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, yid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, yid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, yid, 'units', NCCHAR, 16, unit, iret) name = 'Height'; unit = 'm' - call ncaptc(ncid, zid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, zid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, zid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, zid, 'units', NCCHAR, 16, unit, iret) vid = ncvdef (ncid,'u', NCFLOAT,2,(/pdim,tdim/),iret) name = 'Zonal velocity'; unit = 'm/s' - call ncaptc(ncid, vid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, vid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, vid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, vid, 'units', NCCHAR, 16, unit, iret) vid = ncvdef (ncid,'v', NCFLOAT,2,(/pdim,tdim/),iret) name = 'Meridional velocity'; unit = 'm/s' - call ncaptc(ncid, vid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, vid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, vid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, vid, 'units', NCCHAR, 16, unit, iret) vid = ncvdef (ncid,'w', NCFLOAT,2,(/pdim,tdim/),iret) name = 'Vertical velocity'; unit = 'm/s' - call ncaptc(ncid, vid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, vid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, vid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, vid, 'units', NCCHAR, 16, unit, iret) vid = ncvdef (ncid,'temp', NCFLOAT,2,(/pdim,tdim/),iret) name = 'Temperature'; unit = 'deg C' - call ncaptc(ncid, vid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, vid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, vid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, vid, 'units', NCCHAR, 16, unit, iret) vid = ncvdef (ncid,'salt', NCFLOAT,2,(/pdim,tdim/),iret) name = 'Salinity'; unit = 'g/kg' - call ncaptc(ncid, vid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, vid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, vid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, vid, 'units', NCCHAR, 16, unit, iret) iret = nf_close (ncid) endif @@ -86,7 +86,7 @@ subroutine write_particles !======================================================================= use main_module use particles_module - implicit none + implicit none include "netcdf.inc" integer :: ncid,tdim,tid,xid,yid,zid,iret,ilen,n,uid,vid,wid,teid,sid real*8 :: fxa @@ -107,15 +107,15 @@ subroutine write_particles iret=nf_inq_dimlen(ncid, tdim,ilen) iret=nf_inq_varid(ncid,'Time',tid) ilen=ilen+1 - fxa = itt*dt_tracer/86400.0 + fxa = itt*dt_tracer/86400.0d0 iret= nf_put_vara_double(ncid,tid,ilen,1,fxa) do n=1,nptraj if (coord_degree) then iret= nf_put_vara_double(ncid,xid,(/n,ilen/),(/1,1/),pxyz(1,n)) iret= nf_put_vara_double(ncid,yid,(/n,ilen/),(/1,1/),pxyz(2,n)) else - iret= nf_put_vara_double(ncid,xid,(/n,ilen/),(/1,1/),pxyz(1,n)/1e3) - iret= nf_put_vara_double(ncid,yid,(/n,ilen/),(/1,1/),pxyz(2,n)/1e3) + iret= nf_put_vara_double(ncid,xid,(/n,ilen/),(/1,1/),pxyz(1,n)/1d3) + iret= nf_put_vara_double(ncid,yid,(/n,ilen/),(/1,1/),pxyz(2,n)/1d3) endif iret= nf_put_vara_double(ncid,zid,(/n,ilen/),(/1,1/),pxyz(3,n)) iret= nf_put_vara_double(ncid,uid,(/n,ilen/),(/1,1/),puvw(1,n)) @@ -127,10 +127,3 @@ subroutine write_particles call ncclos (ncid, iret) endif end subroutine write_particles - - - - - - - diff --git a/for_src/diagnostics/diag_snap.f90 b/for_src/diagnostics/diag_snap.f90 index 3502771..d384d5b 100644 --- a/for_src/diagnostics/diag_snap.f90 +++ b/for_src/diagnostics/diag_snap.f90 @@ -6,11 +6,11 @@ subroutine init_snap_cdf !======================================================================= ! initialize NetCDF snapshot file !======================================================================= - use main_module + use main_module use isoneutral_module - use tke_module - use eke_module - use idemix_module + use tke_module + use eke_module + use idemix_module use diagnostics_module implicit none include "netcdf.inc" @@ -81,7 +81,7 @@ subroutine init_snap_cdf id = ncvdef (ncid,name, NCFLOAT,2,dims,iret) write(name, '("Boundary streamfunction ",i3)') n unit = 'm^3/s' - call dvcdf(ncid,id,name,32,unit,16,spval) + call dvcdf(ncid,id,name,32,unit,16,spval) enddo else dims = (/Lon_tdim,lat_tdim,iTimedim,1/) @@ -418,7 +418,7 @@ subroutine init_snap_cdf if (my_pe==0) iret=nf_open(snap_file,NF_WRITE,ncid) bloc(is_pe:ie_pe,js_pe:je_pe) = ht(is_pe:ie_pe,js_pe:je_pe) - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'ht',id) @@ -439,7 +439,7 @@ subroutine init_snap_cdf if (enable_idemix) then bloc(is_pe:ie_pe,js_pe:je_pe) = forc_iw_surface(is_pe:ie_pe,js_pe:je_pe) - where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'forc_iw_surface',id) @@ -447,7 +447,7 @@ subroutine init_snap_cdf endif bloc(is_pe:ie_pe,js_pe:je_pe) = forc_iw_bottom(is_pe:ie_pe,js_pe:je_pe) - where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'forc_iw_bottom',id) @@ -464,11 +464,11 @@ subroutine diag_snap !======================================================================= ! write to NetCDF snapshot file !======================================================================= - use main_module + use main_module use isoneutral_module - use tke_module - use eke_module - use idemix_module + use tke_module + use eke_module + use idemix_module use diagnostics_module implicit none include "netcdf.inc" @@ -484,8 +484,8 @@ subroutine diag_snap iret=nf_inq_dimid(ncid,'Time',itdimid) iret=nf_inq_dimlen(ncid, itdimid,ilen) ilen=ilen+1 - fxa = itt*dt_tracer/86400.0 - if (fxa <1.0) then + fxa = itt*dt_tracer/86400.0d0 + if (fxa <1.0d0) then print'(a,f12.2,a,i4)',' writing snapshot at ',fxa*86400,' s, time steps in file : ',ilen else print'(a,f12.2,a,i4)',' writing snapshot at ',fxa,' d, time steps in file : ',ilen @@ -517,7 +517,7 @@ subroutine diag_snap ! surface temperature flux bloc(is_pe:ie_pe,js_pe:je_pe) = forc_temp_surface(is_pe:ie_pe,js_pe:je_pe) - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'forc_temp_surface',id) @@ -526,7 +526,7 @@ subroutine diag_snap ! surface salinity flux bloc(is_pe:ie_pe,js_pe:je_pe) = forc_salt_surface(is_pe:ie_pe,js_pe:je_pe) - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'forc_salt_surface',id) @@ -535,7 +535,7 @@ subroutine diag_snap ! zonal wind stress bloc(is_pe:ie_pe,js_pe:je_pe) = surface_taux(is_pe:ie_pe,js_pe:je_pe) - where( maskU(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskU(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'taux',id) @@ -544,7 +544,7 @@ subroutine diag_snap ! meridional wind stress bloc(is_pe:ie_pe,js_pe:je_pe) = surface_tauy(is_pe:ie_pe,js_pe:je_pe) - where( maskV(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskV(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'tauy',id) @@ -554,7 +554,7 @@ subroutine diag_snap if (enable_tke) then ! TKE forcing bloc(is_pe:ie_pe,js_pe:je_pe) = forc_tke_surface(is_pe:ie_pe,js_pe:je_pe) - where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'forc_tke',id) @@ -563,7 +563,7 @@ subroutine diag_snap ! surface correction of TKE forcing bloc(is_pe:ie_pe,js_pe:je_pe) = tke_surf_corr(is_pe:ie_pe,js_pe:je_pe) - where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'tke_surf_corr',id) @@ -574,7 +574,7 @@ subroutine diag_snap if (enable_eke) then ! Rossby radius bloc(is_pe:ie_pe,js_pe:je_pe) = L_rossby(is_pe:ie_pe,js_pe:je_pe) - where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'L_Rossby',id) @@ -582,36 +582,36 @@ subroutine diag_snap endif bloc(is_pe:ie_pe,js_pe:je_pe) = eke_bot_flux(is_pe:ie_pe,js_pe:je_pe) - where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe==0) then + if (my_pe==0) then iret=nf_inq_varid(ncid,'eke_bot_flux',id) - iret= nf_put_vara_double(ncid,id,(/1,1,ilen/), (/nx,ny,1/),bloc) + iret= nf_put_vara_double(ncid,id,(/1,1,ilen/), (/nx,ny,1/),bloc) endif if (enable_eke_leewave_dissipation ) then !bloc(is_pe:ie_pe,js_pe:je_pe) = hrms_k0(is_pe:ie_pe,js_pe:je_pe) - !where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + !where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval !call pe0_recv_2D(nx,ny,bloc) - !if (my_pe==0) then + !if (my_pe==0) then ! iret=nf_inq_varid(ncid,'hrms_k0',id) - ! iret= nf_put_vara_double(ncid,id,(/1,1,ilen/), (/nx,ny,1/),bloc) + ! iret= nf_put_vara_double(ncid,id,(/1,1,ilen/), (/nx,ny,1/),bloc) !endif bloc(is_pe:ie_pe,js_pe:je_pe) = c_lee(is_pe:ie_pe,js_pe:je_pe) - where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe==0) then + if (my_pe==0) then iret=nf_inq_varid(ncid,'c_lee',id) - iret= nf_put_vara_double(ncid,id,(/1,1,ilen/), (/nx,ny,1/),bloc) + iret= nf_put_vara_double(ncid,id,(/1,1,ilen/), (/nx,ny,1/),bloc) endif bloc(is_pe:ie_pe,js_pe:je_pe) = eke_lee_flux(is_pe:ie_pe,js_pe:je_pe) - where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe==0) then + if (my_pe==0) then iret=nf_inq_varid(ncid,'eke_lee_flux',id) - iret= nf_put_vara_double(ncid,id,(/1,1,ilen/), (/nx,ny,1/),bloc) + iret= nf_put_vara_double(ncid,id,(/1,1,ilen/), (/nx,ny,1/),bloc) endif endif @@ -624,7 +624,7 @@ subroutine diag_snap bloc(is_pe:ie_pe,js_pe:je_pe) = bloc(is_pe:ie_pe,js_pe:je_pe) + & E_M2(is_pe:ie_pe,js_pe:je_pe,k,tau)*dphit(k)*maskTp(is_pe:ie_pe,js_pe:je_pe,k) enddo - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'E_M2',id) @@ -632,7 +632,7 @@ subroutine diag_snap endif bloc(is_pe:ie_pe,js_pe:je_pe) = cg_M2(is_pe:ie_pe,js_pe:je_pe) - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'cg_M2',id) @@ -640,7 +640,7 @@ subroutine diag_snap endif bloc(is_pe:ie_pe,js_pe:je_pe) = kdot_x_M2(is_pe:ie_pe,js_pe:je_pe) - where( maskU(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskU(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'kdot_x_M2',id) @@ -648,7 +648,7 @@ subroutine diag_snap endif bloc(is_pe:ie_pe,js_pe:je_pe) = kdot_y_M2(is_pe:ie_pe,js_pe:je_pe) - where( maskV(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskV(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'kdot_y_M2',id) @@ -656,7 +656,7 @@ subroutine diag_snap endif bloc(is_pe:ie_pe,js_pe:je_pe) = tau_M2(is_pe:ie_pe,js_pe:je_pe) - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'tau_M2',id) @@ -664,7 +664,7 @@ subroutine diag_snap endif bloc(is_pe:ie_pe,js_pe:je_pe) = alpha_M2_cont(is_pe:ie_pe,js_pe:je_pe) - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'alpha_M2_cont',id) @@ -676,7 +676,7 @@ subroutine diag_snap bloc(is_pe:ie_pe,js_pe:je_pe) = bloc(is_pe:ie_pe,js_pe:je_pe) + & forc_M2(is_pe:ie_pe,js_pe:je_pe,k)*dphit(k)*maskTp(is_pe:ie_pe,js_pe:je_pe,k) enddo - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'forc_M2',id) @@ -694,7 +694,7 @@ subroutine diag_snap bloc(is_pe:ie_pe,js_pe:je_pe) = bloc(is_pe:ie_pe,js_pe:je_pe) + & E_niw(is_pe:ie_pe,js_pe:je_pe,k,tau)*dphit(k)*maskTp(is_pe:ie_pe,js_pe:je_pe,k) enddo - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'E_NIW',id) @@ -702,7 +702,7 @@ subroutine diag_snap endif bloc(is_pe:ie_pe,js_pe:je_pe) = cg_niw(is_pe:ie_pe,js_pe:je_pe) - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'cg_NIW',id) @@ -710,7 +710,7 @@ subroutine diag_snap endif bloc(is_pe:ie_pe,js_pe:je_pe) = kdot_x_niw(is_pe:ie_pe,js_pe:je_pe) - where( maskU(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskU(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'kdot_x_NIW',id) @@ -718,7 +718,7 @@ subroutine diag_snap endif bloc(is_pe:ie_pe,js_pe:je_pe) = kdot_y_niw(is_pe:ie_pe,js_pe:je_pe) - where( maskV(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskV(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'kdot_y_NIW',id) @@ -726,7 +726,7 @@ subroutine diag_snap endif bloc(is_pe:ie_pe,js_pe:je_pe) = tau_niw(is_pe:ie_pe,js_pe:je_pe) - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'tau_NIW',id) @@ -738,7 +738,7 @@ subroutine diag_snap bloc(is_pe:ie_pe,js_pe:je_pe) = bloc(is_pe:ie_pe,js_pe:je_pe) + & forc_niw(is_pe:ie_pe,js_pe:je_pe,k)*dphit(k)*maskTp(is_pe:ie_pe,js_pe:je_pe,k) enddo - where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,nz) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) if (my_pe==0) then iret=nf_inq_varid(ncid,'forc_NIW',id) @@ -754,20 +754,20 @@ subroutine diag_snap do k=1,nz if (.not. enable_hydrostatic) then - ! hydrostatic pressure + ! hydrostatic pressure bloc(is_pe:ie_pe,js_pe:je_pe) = p_hydro(is_pe:ie_pe,js_pe:je_pe,k) - where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'p_hydro',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif - ! non hydrostatic pressure + ! non hydrostatic pressure bloc(is_pe:ie_pe,js_pe:je_pe) = p_non_hydro(is_pe:ie_pe,js_pe:je_pe,k,taup1) - where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'p_non_hydro',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif @@ -775,45 +775,45 @@ subroutine diag_snap ! zonal velocity bloc(is_pe:ie_pe,js_pe:je_pe) = u(is_pe:ie_pe,js_pe:je_pe,k,tau) - where( maskU(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskU(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'u',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! meridional velocity bloc(is_pe:ie_pe,js_pe:je_pe) = v(is_pe:ie_pe,js_pe:je_pe,k,tau) - where( maskV(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskV(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'v',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! vertical velocity bloc(is_pe:ie_pe,js_pe:je_pe) = w(is_pe:ie_pe,js_pe:je_pe,k,tau) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'w',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! temperature bloc(is_pe:ie_pe,js_pe:je_pe) = temp(is_pe:ie_pe,js_pe:je_pe,k,tau) - where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'temp',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! salinity bloc(is_pe:ie_pe,js_pe:je_pe) = salt(is_pe:ie_pe,js_pe:je_pe,k,tau) - where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'salt',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif @@ -821,117 +821,117 @@ subroutine diag_snap if (enable_conserve_energy) then ! dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = K_diss_v(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'K_diss_v',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = K_diss_bot(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'K_diss_bot',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = K_diss_h(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'K_diss_h',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = K_diss_gm(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'K_diss_gm',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = P_diss_v(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'P_diss_v',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = P_diss_hmix(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'P_diss_hmix',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = P_diss_nonlin(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'P_diss_nonlin',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = P_diss_iso(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'P_diss_iso',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = P_diss_skew(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'P_diss_skew',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif endif - + ! stability frequency bloc(is_pe:ie_pe,js_pe:je_pe) = Nsqr(is_pe:ie_pe,js_pe:je_pe,k,tau) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'Nsqr',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! vertical diffusivity bloc(is_pe:ie_pe,js_pe:je_pe) = kappaH(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'kappaH',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif if (enable_neutral_diffusion .and. enable_skew_diffusion) then bloc(is_pe:ie_pe,js_pe:je_pe) = B1_gm(is_pe:ie_pe,js_pe:je_pe,k) - where( maskV(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskV(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'B1_gm',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif bloc(is_pe:ie_pe,js_pe:je_pe) = B2_gm(is_pe:ie_pe,js_pe:je_pe,k) - where( maskU(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskU(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'B2_gm',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif @@ -940,9 +940,9 @@ subroutine diag_snap if (enable_TEM_friction) then ! vertical GM diffusivity bloc(is_pe:ie_pe,js_pe:je_pe) = kappa_gm(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'kappa_gm',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif @@ -951,36 +951,36 @@ subroutine diag_snap if (enable_tke) then ! TKE bloc(is_pe:ie_pe,js_pe:je_pe) = tke(is_pe:ie_pe,js_pe:je_pe,k,tau) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'tke',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif - + ! Prandtl zahl bloc(is_pe:ie_pe,js_pe:je_pe) = Prandtlnumber(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'Prandtl',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! mixing length bloc(is_pe:ie_pe,js_pe:je_pe) = mxl(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'mxl',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! TKE dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = tke_diss(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'tke_diss',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif @@ -992,54 +992,54 @@ subroutine diag_snap ! EKE bloc(is_pe:ie_pe,js_pe:je_pe) = eke(is_pe:ie_pe,js_pe:je_pe,k,tau) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'EKE',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! Rhines scale bloc(is_pe:ie_pe,js_pe:je_pe) = L_Rhines(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'L_Rhines',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! GM diffusivity bloc(is_pe:ie_pe,js_pe:je_pe) = K_gm(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'K_gm',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! Eke dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = eke_diss_iw(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'eke_diss_iw',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! Eke dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = eke_diss_tke(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'eke_diss_tke',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif if (enable_eke_leewave_dissipation ) then bloc(is_pe:ie_pe,js_pe:je_pe) = c_Ri_diss(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'c_Ri_diss',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif @@ -1051,36 +1051,36 @@ subroutine diag_snap ! Internal wave energy bloc(is_pe:ie_pe,js_pe:je_pe) = E_iw(is_pe:ie_pe,js_pe:je_pe,k,tau) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'E_iw',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! Internal wave dissipation bloc(is_pe:ie_pe,js_pe:je_pe) = iw_diss(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'iw_diss',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! Internal wave vertical group velocity bloc(is_pe:ie_pe,js_pe:je_pe) = c0(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'c0',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif ! Internal wave horizontal group velocity bloc(is_pe:ie_pe,js_pe:je_pe) = v0(is_pe:ie_pe,js_pe:je_pe,k) - where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskW(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'v0',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif @@ -1088,9 +1088,9 @@ subroutine diag_snap if (enable_idemix_M2) then bloc(is_pe:ie_pe,js_pe:je_pe) = E_struct_M2(is_pe:ie_pe,js_pe:je_pe,k) - where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'E_struct_M2',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif @@ -1098,9 +1098,9 @@ subroutine diag_snap if (enable_idemix_niw) then bloc(is_pe:ie_pe,js_pe:je_pe) = E_struct_niw(is_pe:ie_pe,js_pe:je_pe,k) - where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.) bloc(is_pe:ie_pe,js_pe:je_pe) = spval + where( maskT(is_pe:ie_pe,js_pe:je_pe,k) == 0.d0) bloc(is_pe:ie_pe,js_pe:je_pe) = spval call pe0_recv_2D(nx,ny,bloc) - if (my_pe == 0 ) then + if (my_pe == 0 ) then iret=nf_inq_varid(ncid,'E_struct_NIW',id) iret= nf_put_vara_double(ncid,id,(/1,1,k,ilen/), (/nx,ny,1,1/),bloc) endif @@ -1131,7 +1131,7 @@ subroutine def_grid_cdf(filename) !======================================================================= ! Define standard grid in netcdf file !======================================================================= - use main_module + use main_module implicit none include "netcdf.inc" character*(*) filename @@ -1161,35 +1161,35 @@ subroutine def_grid_cdf(filename) ! attributes of the grid if (coord_degree) then name = 'Longitude on T grid '; unit = 'degrees E' - call ncaptc(ncid, Lon_tid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, Lon_tid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, Lon_tid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, Lon_tid, 'units', NCCHAR, 16, unit, iret) name = 'Longitude on U grid '; unit = 'degrees E' - call ncaptc(ncid, Lon_uid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, Lon_uid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, Lon_uid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, Lon_uid, 'units', NCCHAR, 16, unit, iret) name = 'Latitude on T grid '; unit = 'degrees N' - call ncaptc(ncid, Lat_tid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, Lat_tid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, Lat_tid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, Lat_tid, 'units', NCCHAR, 16, unit, iret) name = 'Latitude on U grid '; unit = 'degrees N' - call ncaptc(ncid, Lat_uid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, Lat_uid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, Lat_uid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, Lat_uid, 'units', NCCHAR, 16, unit, iret) else name = 'zonal axis T grid '; unit = 'km' - call ncaptc(ncid, Lon_tid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, Lon_tid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, Lon_tid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, Lon_tid, 'units', NCCHAR, 16, unit, iret) name = 'zonal axis U grid '; unit = 'km' - call ncaptc(ncid, Lon_uid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, Lon_uid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, Lon_uid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, Lon_uid, 'units', NCCHAR, 16, unit, iret) name = 'meridional axis T grid'; unit = 'km' - call ncaptc(ncid, Lat_tid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, Lat_tid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, Lat_tid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, Lat_tid, 'units', NCCHAR, 16, unit, iret) name = 'meridional axis U grid'; unit = 'km' - call ncaptc(ncid, Lat_uid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, Lat_uid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, Lat_uid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, Lat_uid, 'units', NCCHAR, 16, unit, iret) endif name = 'Time '; unit = 'days' - call ncaptc(ncid, itimeid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, itimeid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, itimeid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, itimeid, 'units', NCCHAR, 16, unit, iret) call ncaptc(ncid, iTimeid,'time_origin',NCCHAR, 20,'01-JAN-1900 00:00:00', iret) z_tdim = ncddef(ncid, 'zt', nz, iret) @@ -1197,11 +1197,11 @@ subroutine def_grid_cdf(filename) z_tid = ncvdef (ncid,'zt', NCFLOAT,1,z_tdim,iret) z_uid = ncvdef (ncid,'zu', NCFLOAT,1,z_udim,iret) name = 'Height on T grid '; unit = 'm' - call ncaptc(ncid, z_tid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, z_tid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, z_tid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, z_tid, 'units', NCCHAR, 16, unit, iret) name = 'Height on U grid '; unit = 'm' - call ncaptc(ncid, z_uid, 'long_name', NCCHAR, 24, name, iret) - call ncaptc(ncid, z_uid, 'units', NCCHAR, 16, unit, iret) + call ncaptc(ncid, z_uid, 'long_name', NCCHAR, 24, name, iret) + call ncaptc(ncid, z_uid, 'units', NCCHAR, 16, unit, iret) call ncendf(ncid, iret) iret= nf_put_vara_double(ncid,z_tid,1,nz ,zt) @@ -1224,10 +1224,10 @@ subroutine def_grid_cdf(filename) iret= nf_put_vara_double(ncid,lat_Tid,js_pe,je_pe-js_pe+1 ,yt(js_pe:je_pe)) iret= nf_put_vara_double(ncid,lat_uid,js_pe,je_pe-js_pe+1 ,yu(js_pe:je_pe)) else - iret= nf_put_vara_double(ncid,lon_Tid,is_pe,ie_pe-is_pe+1 ,xt(is_pe:ie_pe)/1e3) - iret= nf_put_vara_double(ncid,lon_uid,is_pe,ie_pe-is_pe+1 ,xu(is_pe:ie_pe)/1e3) - iret= nf_put_vara_double(ncid,lat_Tid,js_pe,je_pe-js_pe+1 ,yt(js_pe:je_pe)/1e3) - iret= nf_put_vara_double(ncid,lat_uid,js_pe,je_pe-js_pe+1 ,yu(js_pe:je_pe)/1e3) + iret= nf_put_vara_double(ncid,lon_Tid,is_pe,ie_pe-is_pe+1 ,xt(is_pe:ie_pe)/1d3) + iret= nf_put_vara_double(ncid,lon_uid,is_pe,ie_pe-is_pe+1 ,xu(is_pe:ie_pe)/1d3) + iret= nf_put_vara_double(ncid,lat_Tid,js_pe,je_pe-js_pe+1 ,yt(js_pe:je_pe)/1d3) + iret= nf_put_vara_double(ncid,lat_uid,js_pe,je_pe-js_pe+1 ,yu(js_pe:je_pe)/1d3) endif call ncclos (ncid, iret) endif @@ -1240,7 +1240,7 @@ end subroutine def_grid_cdf subroutine dvcdf(ncid,ivarid,name,iname,unit,iunit,spval) !======================================================================= -! define some standard attributes of variable ivarid in NetCDF file ncid +! define some standard attributes of variable ivarid in NetCDF file ncid !======================================================================= implicit none integer ncid,ivarid,iname,iunit,iret @@ -1248,16 +1248,12 @@ subroutine dvcdf(ncid,ivarid,name,iname,unit,iunit,spval) real*8 :: spval, vv include "netcdf.inc" vv=spval - call ncaptc(ncid,ivarid, 'long_name', NCCHAR,iname , name, iret) + call ncaptc(ncid,ivarid, 'long_name', NCCHAR,iname , name, iret) if (iret.ne.0) print*,nf_strerror(iret) - call ncaptc(ncid,ivarid, 'units', NCCHAR,iunit, unit, iret) + call ncaptc(ncid,ivarid, 'units', NCCHAR,iunit, unit, iret) if (iret.ne.0) print*,nf_strerror(iret) call ncapt (ncid,ivarid, 'missing_value',NCDOUBLE,1,vv,iret) if (iret.ne.0) print*,nf_strerror(iret) call ncapt (ncid,ivarid, '_FillValue', NCDOUBLE, 1,vv, iret) if (iret.ne.0) print*,nf_strerror(iret) end subroutine dvcdf - - - - diff --git a/for_src/diagnostics/diagnostics_module.f90 b/for_src/diagnostics/diagnostics_module.f90 index 4b7060d..daf9faf 100644 --- a/for_src/diagnostics/diagnostics_module.f90 +++ b/for_src/diagnostics/diagnostics_module.f90 @@ -14,19 +14,14 @@ module diagnostics_module logical :: enable_diag_particles = .false. ! enable integration of particles character*80 :: snap_file = 'pyOM.cdf' character*80 :: diag_energy_file = 'energy.cdf' - real*8 :: snapint=0. ! intervall between snapshots to be written in seconds - real*8 :: aveint=0. ! intervall between time averages to be written in seconds - real*8 :: energint=0. ! intervall between energy diag to be written in seconds - real*8 :: energfreq=0.! diagnosing every energfreq seconds - real*8 :: ts_monint=0.! intervall between time step monitor in seconds - real*8 :: avefreq=0. ! averaging every ave_freq seconds - real*8 :: overint=0. ! intervall between overturning averages to be written in seconds - real*8 :: overfreq=0. ! averaging overturning every ave_freq seconds - real*8 :: trac_cont_int=0.! intervall between tracer content monitor in seconds - real*8 :: particles_int=0. ! intervall + real*8 :: snapint=0.d0 ! intervall between snapshots to be written in seconds + real*8 :: aveint=0.d0 ! intervall between time averages to be written in seconds + real*8 :: energint=0.d0 ! intervall between energy diag to be written in seconds + real*8 :: energfreq=0.d0! diagnosing every energfreq seconds + real*8 :: ts_monint=0.d0! intervall between time step monitor in seconds + real*8 :: avefreq=0.d0 ! averaging every ave_freq seconds + real*8 :: overint=0.d0 ! intervall between overturning averages to be written in seconds + real*8 :: overfreq=0.d0 ! averaging overturning every ave_freq seconds + real*8 :: trac_cont_int=0.d0! intervall between tracer content monitor in seconds + real*8 :: particles_int=0.d0 ! intervall end module diagnostics_module - - - - - diff --git a/for_src/eke/eke.f90 b/for_src/eke/eke.f90 index a8d87e9..30f7c3c 100644 --- a/for_src/eke/eke.f90 +++ b/for_src/eke/eke.f90 @@ -4,11 +4,11 @@ subroutine init_eke !======================================================================= ! Initialize EKE !======================================================================= - use main_module - use eke_module + use main_module + use eke_module if (enable_eke_leewave_dissipation ) then - hrms_k0 = max(eke_hrms_k0_min, 2/pi*eke_topo_hrms**2/max(1d-12,eke_topo_lam)**1.5 ) + hrms_k0 = max(eke_hrms_k0_min, 2/pi*eke_topo_hrms**2/max(1d-12,eke_topo_lam)**1.5d0 ) endif end subroutine init_eke @@ -18,9 +18,9 @@ subroutine set_eke_diffusivities ! set skew diffusivity K_gm and isopycnal diffusivity K_iso ! set also vertical viscosity if TEM formalism is chosen !======================================================================= - use main_module - use isoneutral_module - use eke_module + use main_module + use isoneutral_module + use eke_module implicit none integer :: i,j,k real*8 :: C_rossby(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx) @@ -29,9 +29,9 @@ subroutine set_eke_diffusivities !--------------------------------------------------------------------------------- ! calculate Rossby radius as minimum of mid-latitude and equatorial R. rad. !--------------------------------------------------------------------------------- - C_rossby = 0.0 + C_rossby = 0.0d0 do k=1,nz - C_Rossby(:,:) = C_Rossby(:,:) + sqrt(max(0D0,Nsqr(:,:,k,tau)))*dzw(k)*maskW(:,:,k)/pi + C_Rossby(:,:) = C_Rossby(:,:) + sqrt(max(0D0,Nsqr(:,:,k,tau)))*dzw(k)*maskW(:,:,k)/pi enddo do j=js_pe-onx,je_pe+onx do i=is_pe-onx,ie_pe+onx @@ -40,7 +40,7 @@ subroutine set_eke_diffusivities enddo enddo !--------------------------------------------------------------------------------- - ! calculate vertical viscosity and skew diffusivity + ! calculate vertical viscosity and skew diffusivity !--------------------------------------------------------------------------------- sqrteke = sqrt(max(0d0,eke(:,:,:,tau))) do k=1,nz @@ -55,7 +55,7 @@ subroutine set_eke_diffusivities K_gm = K_gm_0 endif - if (enable_TEM_friction) then + if (enable_TEM_friction) then do j=js_pe-onx,je_pe+onx do i=is_pe-onx,ie_pe+onx kappa_gm(i,j,:) = K_gm(i,j,:)*min(0.01D0,coriolis_t(i,j)**2/max(1d-9,Nsqr(i,j,:,tau)) )*maskW(i,j,:) @@ -64,7 +64,7 @@ subroutine set_eke_diffusivities endif if (enable_eke .and.enable_eke_isopycnal_diffusion) then - K_iso = K_gm + K_iso = K_gm else K_iso = K_iso_0 ! always constant endif @@ -76,9 +76,9 @@ subroutine integrate_eke !======================================================================= ! integrate EKE equation on W grid !======================================================================= - use main_module - use isoneutral_module - use eke_module + use main_module + use isoneutral_module + use eke_module implicit none integer :: i,j,k,ks,ke real*8 :: a_tri(nz),b_tri(nz),c_tri(nz),d_tri(nz),delta(nz) @@ -91,9 +91,9 @@ subroutine integrate_eke ! forcing by dissipation by lateral friction and GM using TRM formalism or skew diffusion !--------------------------------------------------------------------------------- forc = K_diss_h + K_diss_gm - P_diss_skew - + !--------------------------------------------------------------------------------- - ! store transfer due to isopycnal and horizontal mixing from dyn. enthalpy + ! store transfer due to isopycnal and horizontal mixing from dyn. enthalpy ! by non-linear eq.of state either to EKE or to heat !--------------------------------------------------------------------------------- if (.not. enable_store_cabbeling_heat) forc = forc - P_diss_hmix - P_diss_iso @@ -111,9 +111,9 @@ subroutine integrate_eke do j=js_pe,je_pe do i=is_pe,ie_pe k=kbot(i,j) - if (k>0.and. k0 .and. k0.and.k0.and.k0.and.k0.and.k 0.0) - a_loc = a_loc/b_loc + where (b_loc > 0.0d0) + a_loc = a_loc/b_loc elsewhere - a_loc=0.0 + a_loc=0.0d0 end where do k=1,nz c_int(:,:,k) = a_loc enddo - else + else !--------------------------------------------------------------------------------- ! dissipation by local interior loss of balance with constant coefficient !--------------------------------------------------------------------------------- @@ -198,26 +198,26 @@ subroutine integrate_eke ks=kbot(i,j) if (ks>0) then do k=ks,ke-1 - delta(k) = dt_tracer/dzt(k+1)*0.5*(kappaM(i,j,k)+KappaM(i,j,k+1))*alpha_eke + delta(k) = dt_tracer/dzt(k+1)*0.5d0*(kappaM(i,j,k)+KappaM(i,j,k+1))*alpha_eke enddo - delta(ke)=0.0 + delta(ke)=0.0d0 do k=ks+1,ke-1 a_tri(k) = - delta(k-1)/dzw(k) enddo - a_tri(ks)=0.0 - a_tri(ke) = - delta(ke-1)/(0.5*dzw(ke)) + a_tri(ks)=0.0d0 + a_tri(ke) = - delta(ke-1)/(0.5d0*dzw(ke)) do k=ks+1,ke-1 b_tri(k) = 1+ delta(k)/dzw(k) + delta(k-1)/dzw(k) + dt_tracer*c_int(i,j,k) enddo - b_tri(ke) = 1+ delta(ke-1)/(0.5*dzw(ke)) + dt_tracer*c_int(i,j,ke) - b_tri(ks) = 1+ delta(ks)/dzw(ks) + dt_tracer*c_int(i,j,ks) + b_tri(ke) = 1+ delta(ke-1)/(0.5d0*dzw(ke)) + dt_tracer*c_int(i,j,ke) + b_tri(ks) = 1+ delta(ks)/dzw(ks) + dt_tracer*c_int(i,j,ks) do k=ks,ke-1 c_tri(k) = - delta(k)/dzw(k) enddo - c_tri(ke)=0.0 + c_tri(ke)=0.0d0 d_tri(ks:ke)=eke(i,j,ks:ke,tau) + dt_tracer*forc(i,j,ks:ke) - d_tri(ks) = d_tri(ks) - d_tri(ke) = d_tri(ke) !+ dt_tracer*forc_eke_surfac(i,j)/(0.5*dzw(ke)) + d_tri(ks) = d_tri(ks) + d_tri(ke) = d_tri(ke) !+ dt_tracer*forc_eke_surfac(i,j)/(0.5d0*dzw(ke)) call solve_tridiag(a_tri(ks:ke),b_tri(ks:ke),c_tri(ks:ke),d_tri(ks:ke),eke(i,j,ks:ke,taup1),ke-ks+1) endif enddo @@ -226,7 +226,7 @@ subroutine integrate_eke !--------------------------------------------------------------------------------- - ! store eke dissipation + ! store eke dissipation !--------------------------------------------------------------------------------- if (enable_eke_leewave_dissipation ) then @@ -241,7 +241,7 @@ subroutine integrate_eke k=kbot(i,j) if (k>0.and.k0.and.k sum G = (sum c_int e) /(sum F ) sum F @@ -275,7 +275,7 @@ subroutine integrate_eke do i=is_pe,ie_pe k=kbot(i,j) if (k>0.and.k0.and.k0.and.k= pi .and. phit(k) < 2*pi ) then + if (phit(k) >= pi .and. phit(k) < 2*pi ) then fxa=2*pi-phit(k) - if (fxa < 0.) fxa = fxa + 2*pi + if (fxa < 0.d0) fxa = fxa + 2*pi if (fxa > 2*pi) fxa = fxa - 2*pi kk = minloc( (phit - fxa)**2,1 ) do j=js_pe-1,je_pe - where (maskTp(is_pe:ie_pe,j,k) == 0.0 .and. maskTp(is_pe:ie_pe,j+1,k)== 1.0) bc_south(is_pe:ie_pe,j,k)=kk + where (maskTp(is_pe:ie_pe,j,k) == 0.0d0 .and. maskTp(is_pe:ie_pe,j+1,k)== 1.0d0) bc_south(is_pe:ie_pe,j,k)=kk enddo !endif ! northern boundary von 0 bis pi - !if ( phit(k) >= 0. .and. phit(k) <= pi ) then + !if ( phit(k) >= 0.d0 .and. phit(k) <= pi ) then else fxa=2*pi-phit(k) - if (fxa < 0.) fxa = fxa + 2*pi + if (fxa < 0.d0) fxa = fxa + 2*pi if (fxa > 2*pi) fxa = fxa - 2*pi kk = minloc( (phit - fxa)**2,1 ) do j=js_pe-1,je_pe - where (maskTp(is_pe:ie_pe,j,k) == 1.0 .and. maskTp(is_pe:ie_pe,j+1,k)== 0.0) bc_north(is_pe:ie_pe,j,k)=kk + where (maskTp(is_pe:ie_pe,j,k) == 1.0d0 .and. maskTp(is_pe:ie_pe,j+1,k)== 0.0d0) bc_north(is_pe:ie_pe,j,k)=kk enddo endif @@ -191,26 +191,26 @@ subroutine reflect_ini do k=2,np-1 - ! western boundary: from 0.5 pi to 0.75 pi - if (phit(k) >= pi/2 .and. phit(k) < 3*pi/2. ) then + ! western boundary: from 0.5d0 pi to 0.75d0 pi + if (phit(k) >= pi/2 .and. phit(k) < 3*pi/2.d0 ) then fxa=pi- phit(k) - if (fxa < 0.) fxa = fxa + 2*pi + if (fxa < 0.d0) fxa = fxa + 2*pi if (fxa > 2*pi) fxa = fxa - 2*pi kk = minloc( (phit - fxa)**2,1 ) do i=is_pe-1,ie_pe - where (maskTp(i,js_pe:je_pe,k) == 0.0 .and. maskTp(i+1,js_pe:je_pe,k)== 1.0) bc_west(i,js_pe:je_pe,k)=kk + where (maskTp(i,js_pe:je_pe,k) == 0.0d0 .and. maskTp(i+1,js_pe:je_pe,k)== 1.0d0) bc_west(i,js_pe:je_pe,k)=kk enddo !endif - ! eastern boundary: from 0 to 0.5 pi and from 0.75 pi to 2 pi - !if ( ( phit(k) >= 0. .and. phit(k) <= pi/2 ) .or. (phit(k) >= 3*pi/2. .and. phit(k) <= 2*pi ) ) then + ! eastern boundary: from 0 to 0.5d0 pi and from 0.75d0 pi to 2 pi + !if ( ( phit(k) >= 0.d0 .and. phit(k) <= pi/2 ) .or. (phit(k) >= 3*pi/2.d0 .and. phit(k) <= 2*pi ) ) then else fxa=pi-phit(k) - if (fxa < 0.) fxa = fxa + 2*pi + if (fxa < 0.d0) fxa = fxa + 2*pi if (fxa > 2*pi) fxa = fxa - 2*pi kk = minloc( (phit - fxa)**2,1 ) do i=is_pe-1,ie_pe - where (maskTp(i,js_pe:je_pe,k) == 1.0 .and. maskTp(i+1,js_pe:je_pe,k)== 0.0) bc_east(i,js_pe:je_pe,k)=kk + where (maskTp(i,js_pe:je_pe,k) == 1.0d0 .and. maskTp(i+1,js_pe:je_pe,k)== 0.0d0) bc_east(i,js_pe:je_pe,k)=kk enddo endif enddo @@ -224,26 +224,26 @@ subroutine calc_spectral_topo !======================================================================= ! spectral stuff related to topography !======================================================================= - use main_module - use idemix_module + use main_module + use idemix_module implicit none integer :: i,j,k if (enable_idemix_M2 .or. enable_idemix_niw) then - ! wavenumber grid - dphit=2.*pi/(np-2); dphiu=dphit - phit(1)=0.0-dphit(1); phiu(1)=phit(1)+dphit(1)/2. + ! wavenumber grid + dphit=2.d0*pi/(np-2); dphiu=dphit + phit(1)=0.0d0-dphit(1); phiu(1)=phit(1)+dphit(1)/2.d0 do i=2,np phit(i)=phit(i-1)+dphit(i); phiu(i)=phiu(i-1)+dphiu(i) enddo ! topographic mask for waves - maskTp=0.0 + maskTp=0.0d0 do j=js_pe,je_pe do i=is_pe,ie_pe - if ( kbot(i,j) /=0 ) maskTp(i,j,:)=1.0 + if ( kbot(i,j) /=0 ) maskTp(i,j,:)=1.0d0 enddo enddo - call border_exchg_xyp(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,np,maskTp) + call border_exchg_xyp(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,np,maskTp) call setcyclic_xyp (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,np,maskTp) maskUp=maskTp do i=is_pe-onx,ie_pe+onx-1 diff --git a/for_src/isoneutral/isoneutral.f90 b/for_src/isoneutral/isoneutral.f90 index 5394419..9e165dc 100644 --- a/for_src/isoneutral/isoneutral.f90 +++ b/for_src/isoneutral/isoneutral.f90 @@ -3,10 +3,10 @@ subroutine isoneutral_diffusion_pre !======================================================================= ! Isopycnal diffusion for tracer -! following functional formulation by Griffies et al -! Code adopted from MOM2.1 +! following functional formulation by Griffies et al +! Code adopted from MOM2.1d0 !======================================================================= - use main_module + use main_module use isoneutral_module implicit none integer :: i,j,k,ip,jp,kr @@ -21,13 +21,13 @@ subroutine isoneutral_diffusion_pre !----------------------------------------------------------------------- ! statement functions for density triads !----------------------------------------------------------------------- - drodxe(i,j,k,ip) = drdTS(i+ip,j,k,1)*ddxt(i,j,k,1) + drdTS(i+ip,j,k,2)*ddxt(i,j,k,2) + drodxe(i,j,k,ip) = drdTS(i+ip,j,k,1)*ddxt(i,j,k,1) + drdTS(i+ip,j,k,2)*ddxt(i,j,k,2) drodze(i,j,k,ip,kr) = drdTS(i+ip,j,k,1)*ddzt(i+ip,j,k+kr-1,1) + drdTS(i+ip,j,k,2)*ddzt(i+ip,j,k+kr-1,2) - drodyn(i,j,k,jp) = drdTS(i,j+jp,k,1)*ddyt(i,j,k,1) + drdTS(i,j+jp,k,2)*ddyt(i,j,k,2) + drodyn(i,j,k,jp) = drdTS(i,j+jp,k,1)*ddyt(i,j,k,1) + drdTS(i,j+jp,k,2)*ddyt(i,j,k,2) drodzn(i,j,k,jp,kr) = drdTS(i,j+jp,k,1)*ddzt(i,j+jp,k+kr-1,1) + drdTS(i,j+jp,k,2)*ddzt(i,j+jp,k+kr-1,2) - drodxb(i,j,k,ip,kr) = drdTS(i,j,k+kr,1)*ddxt(i-1+ip,j,k+kr,1) + drdTS(i,j,k+kr,2)*ddxt(i-1+ip,j,k+kr,2) - drodyb(i,j,k,jp,kr) = drdTS(i,j,k+kr,1)*ddyt(i,j-1+jp,k+kr,1) + drdTS(i,j,k+kr,2)*ddyt(i,j-1+jp,k+kr,2) + drodxb(i,j,k,ip,kr) = drdTS(i,j,k+kr,1)*ddxt(i-1+ip,j,k+kr,1) + drdTS(i,j,k+kr,2)*ddxt(i-1+ip,j,k+kr,2) + drodyb(i,j,k,jp,kr) = drdTS(i,j,k+kr,1)*ddyt(i,j-1+jp,k+kr,1) + drdTS(i,j,k+kr,2)*ddyt(i,j-1+jp,k+kr,2) drodzb(i,j,k,kr) = drdTS(i,j,k+kr,1)*ddzt(i,j,k,1) + drdTS(i,j,k+kr,2)*ddzt(i,j,k,2) !----------------------------------------------------------------------- ! drho_dt and drho_ds at centers of T cells @@ -46,8 +46,8 @@ subroutine isoneutral_diffusion_pre do k=1,nz-1 do j=js_pe-onx,je_pe+onx do i=is_pe-onx,ie_pe+onx - ddzt(i,j,k,1) = maskW(i,j,k)* (temp(i,j,k+1,tau) - temp(i,j,k,tau))/dzw(k) - ddzt(i,j,k,2) = maskW(i,j,k)* (salt(i,j,k+1,tau) - salt(i,j,k,tau))/dzw(k) + ddzt(i,j,k,1) = maskW(i,j,k)* (temp(i,j,k+1,tau) - temp(i,j,k,tau))/dzw(k) + ddzt(i,j,k,2) = maskW(i,j,k)* (salt(i,j,k+1,tau) - salt(i,j,k,tau))/dzw(k) enddo enddo enddo @@ -76,12 +76,12 @@ subroutine isoneutral_diffusion_pre do k=2,nz do j=js_pe,je_pe do i=is_pe-1,ie_pe - diffloc = 0.25*(K_iso(i,j,k)+K_iso(i,j,k-1) + K_iso(i+1,j,k)+K_iso(i+1,j,k-1) ) - sumz = 0. + diffloc = 0.25d0*(K_iso(i,j,k)+K_iso(i,j,k-1) + K_iso(i+1,j,k)+K_iso(i+1,j,k-1) ) + sumz = 0.d0 do kr=0,1 do ip=0,1 sxe = -drodxe(i,j,k,ip)/(min(0d0,drodze(i,j,k,ip,kr))-epsln) ! i+1, k-1 - taper = dm_taper(sxe) + taper = dm_taper(sxe) sumz = sumz + dzw(k+kr-1)*maskU(i,j,k)*max(K_iso_steep,diffloc*taper) Ai_ez(i,j,k,ip,kr) = taper*sxe*maskU(i,j,k) enddo @@ -93,12 +93,12 @@ subroutine isoneutral_diffusion_pre k=1 do j=js_pe,je_pe do i=is_pe-1,ie_pe - diffloc = 0.5*(K_iso(i,j,k)+ K_iso(i+1,j,k) ) - sumz = 0. + diffloc = 0.5d0*(K_iso(i,j,k)+ K_iso(i+1,j,k) ) + sumz = 0.d0 kr=1 do ip=0,1 sxe = -drodxe(i,j,k,ip)/(min(0d0,drodze(i,j,k,ip,kr))-epsln) - taper = dm_taper(sxe) + taper = dm_taper(sxe) sumz = sumz + dzw(k+kr-1)*maskU(i,j,k)*max(K_iso_steep,diffloc*taper) Ai_ez(i,j,k,ip,kr) = taper*sxe*maskU(i,j,k) enddo @@ -111,12 +111,12 @@ subroutine isoneutral_diffusion_pre do k=2,nz do j=js_pe-1,je_pe do i=is_pe,ie_pe - diffloc = 0.25*(K_iso(i,j,k)+K_iso(i,j,k-1) + K_iso(i,j+1,k)+K_iso(i,j+1,k-1) ) - sumz = 0. + diffloc = 0.25d0*(K_iso(i,j,k)+K_iso(i,j,k-1) + K_iso(i,j+1,k)+K_iso(i,j+1,k-1) ) + sumz = 0.d0 do kr=0,1 do jp=0,1 syn = -drodyn(i,j,k,jp)/(min(0d0,drodzn(i,j,k,jp,kr))-epsln) - taper = dm_taper(syn) + taper = dm_taper(syn) sumz = sumz + dzw(k+kr-1) *maskV(i,j,k)*max(K_iso_steep,diffloc*taper) Ai_nz(i,j,k,jp,kr) = taper*syn*maskV(i,j,k) enddo @@ -128,12 +128,12 @@ subroutine isoneutral_diffusion_pre k=1 do j=js_pe-1,je_pe do i=is_pe,ie_pe - diffloc = 0.5*(K_iso(i,j,k) + K_iso(i,j+1,k)) - sumz = 0. + diffloc = 0.5d0*(K_iso(i,j,k) + K_iso(i,j+1,k)) + sumz = 0.d0 kr=1 do jp=0,1 syn = -drodyn(i,j,k,jp)/(min(0d0,drodzn(i,j,k,jp,kr))-epsln) - taper = dm_taper(syn) + taper = dm_taper(syn) sumz = sumz + dzw(k+kr-1) *maskV(i,j,k)*max(K_iso_steep,diffloc*taper) Ai_nz(i,j,k,jp,kr) = taper*syn*maskV(i,j,k) enddo @@ -147,22 +147,22 @@ subroutine isoneutral_diffusion_pre do j=js_pe,je_pe do i=is_pe,ie_pe ! eastward slopes at the top of T cells - sumx = 0. + sumx = 0.d0 do ip=0,1 do kr=0,1 sxb = -drodxb(i,j,k,ip,kr)/(min(0d0,drodzb(i,j,k,kr))-epsln) ! i-1,k+1 - taper = dm_taper(sxb) + taper = dm_taper(sxb) sumx = sumx + dxu(i-1+ip)*K_iso(i,j,k)*taper*sxb**2 *maskW(i,j,k) Ai_bx(i,j,k,ip,kr) = taper*sxb*maskW(i,j,k) enddo enddo ! northward slopes at the top of T cells - sumy = 0. + sumy = 0.d0 do jp=0,1 facty = cosu(j-1+jp)*dyu(j-1+jp) do kr=0,1 syb = -drodyb(i,j,k,jp,kr)/(min(0d0,drodzb(i,j,k,kr))-epsln) - taper = dm_taper(syb) + taper = dm_taper(syb) sumy = sumy + facty*K_iso(i,j,k)*taper*syb**2 *maskW(i,j,k) Ai_by(i,j,k,jp,kr) = taper*syb *maskW(i,j,k) enddo @@ -183,46 +183,46 @@ subroutine isoneutral_diag_streamfunction ! calculate hor. components of streamfunction for eddy driven velocity ! for diagnostics purpose only !======================================================================= - use main_module + use main_module use isoneutral_module implicit none integer :: i,j,k,kr,ip,jp,km1kr,kpkr real*8 :: sumz, diffloc !----------------------------------------------------------------------- -! meridional component at east face of "T" cells +! meridional component at east face of "T" cells !----------------------------------------------------------------------- do k=1,nz do j=js_pe,je_pe do i=is_pe-1,ie_pe - diffloc = 0.25*(K_gm(i,j,k)+K_gm(i,j,max(1,k-1)) + K_gm(i+1,j,k)+K_gm(i+1,j,max(1,k-1)) ) - sumz = 0. + diffloc = 0.25d0*(K_gm(i,j,k)+K_gm(i,j,max(1,k-1)) + K_gm(i+1,j,k)+K_gm(i+1,j,max(1,k-1)) ) + sumz = 0.d0 do kr=0,1 km1kr = max(k-1+kr,1) kpkr = min(k+kr,nz) do ip=0,1 - sumz = sumz + diffloc*Ai_ez(i,j,k,ip,kr) + sumz = sumz + diffloc*Ai_ez(i,j,k,ip,kr) enddo enddo - B2_gm(i,j,k) = 0.25*sumz + B2_gm(i,j,k) = 0.25d0*sumz enddo enddo enddo !----------------------------------------------------------------------- -! zonal component at north face of "T" cells +! zonal component at north face of "T" cells !----------------------------------------------------------------------- do k=1,nz do j=js_pe-1,je_pe do i=is_pe,ie_pe - diffloc = 0.25*(K_gm(i,j,k)+K_gm(i,j,max(1,k-1)) + K_gm(i,j+1,k)+K_gm(i,j+1,max(1,k-1)) ) - sumz = 0. + diffloc = 0.25d0*(K_gm(i,j,k)+K_gm(i,j,max(1,k-1)) + K_gm(i,j+1,k)+K_gm(i,j+1,max(1,k-1)) ) + sumz = 0.d0 do kr=0,1 km1kr = max(k-1+kr,1) kpkr = min(k+kr,nz) do jp=0,1 - sumz = sumz + diffloc*Ai_nz(i,j,k,jp,kr) + sumz = sumz + diffloc*Ai_nz(i,j,k,jp,kr) enddo enddo - B1_gm(i,j,k) = -0.25*sumz + B1_gm(i,j,k) = -0.25d0*sumz enddo enddo enddo @@ -236,14 +236,14 @@ real*8 function dm_taper(sx) use isoneutral_module implicit none real*8 :: sx - dm_taper=0.5*(1.+tanh((-abs(sx)+iso_slopec)/iso_dslope)) + dm_taper=0.5d0*(1.d0+tanh((-abs(sx)+iso_slopec)/iso_dslope)) end function dm_taper subroutine check_isoneutral_slope_crit !======================================================================= -! check linear stability criterion from Griffies et al +! check linear stability criterion from Griffies et al !======================================================================= use main_module use isoneutral_module @@ -253,7 +253,7 @@ subroutine check_isoneutral_slope_crit if (enable_neutral_diffusion) then - ft1 = 1.0/(4.0*K_iso_0*dt_tracer + epsln) + ft1 = 1.0d0/(4.0d0*K_iso_0*dt_tracer + epsln) i = is_pe+onx; j= js_pe+onx; k = 1 delta_iso1 = dzt(k)*ft1*dxt(i)*abs(cost(j)) @@ -264,7 +264,7 @@ subroutine check_isoneutral_slope_crit delta1b = dyt(j)*dzt(k)*ft1 if ( delta_iso1 .ge. delta1a .or. delta_iso1 .ge. delta1b) then delta_iso1 = min(delta1a,delta1b) - endif + endif enddo enddo enddo @@ -284,5 +284,3 @@ subroutine check_isoneutral_slope_crit if (delta_iso1 < iso_slopec) call halt_stop(' in check_slop_crit') endif end subroutine check_isoneutral_slope_crit - - diff --git a/for_src/isoneutral/isoneutral_diffusion.f90 b/for_src/isoneutral/isoneutral_diffusion.f90 index 2783904..2ccf689 100644 --- a/for_src/isoneutral/isoneutral_diffusion.f90 +++ b/for_src/isoneutral/isoneutral_diffusion.f90 @@ -5,12 +5,12 @@ subroutine isoneutral_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) !======================================================================= -! Isopycnal diffusion for tracer, -! following functional formulation by Griffies et al +! Isopycnal diffusion for tracer, +! following functional formulation by Griffies et al ! Dissipation is calculated and stored in P_diss_iso ! T/S changes are added to dtemp_iso/dsalt_iso !======================================================================= - use main_module + use main_module use isoneutral_module implicit none integer :: is_,ie_,js_,je_,nz_ @@ -24,13 +24,13 @@ subroutine isoneutral_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) real*8 :: fxa,diffloc !----------------------------------------------------------------------- -! construct total isoneutral tracer flux at east face of "T" cells +! construct total isoneutral tracer flux at east face of "T" cells !----------------------------------------------------------------------- do k=1,nz do j=js_pe,je_pe do i=is_pe-1,ie_pe - diffloc = 0.25*(K_iso(i,j,k)+K_iso(i,j,max(1,k-1)) + K_iso(i+1,j,k)+K_iso(i+1,j,max(1,k-1)) ) - sumz = 0. + diffloc = 0.25d0*(K_iso(i,j,k)+K_iso(i,j,max(1,k-1)) + K_iso(i+1,j,k)+K_iso(i+1,j,max(1,k-1)) ) + sumz = 0.d0 do kr=0,1 km1kr = max(k-1+kr,1) kpkr = min(k+kr,nz) @@ -43,13 +43,13 @@ subroutine isoneutral_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) enddo enddo !----------------------------------------------------------------------- -! construct total isoneutral tracer flux at north face of "T" cells +! construct total isoneutral tracer flux at north face of "T" cells !----------------------------------------------------------------------- do k=1,nz do j=js_pe-1,je_pe do i=is_pe,ie_pe - diffloc = 0.25*(K_iso(i,j,k)+K_iso(i,j,max(1,k-1)) + K_iso(i,j+1,k)+K_iso(i,j+1,max(1,k-1)) ) - sumz = 0. + diffloc = 0.25d0*(K_iso(i,j,k)+K_iso(i,j,max(1,k-1)) + K_iso(i,j+1,k)+K_iso(i,j+1,max(1,k-1)) ) + sumz = 0.d0 do kr=0,1 km1kr = max(k-1+kr,1) kpkr = min(k+kr,nz) @@ -65,31 +65,31 @@ subroutine isoneutral_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) ! compute the vertical tracer flux "flux_top" containing the K31 ! and K32 components which are to be solved explicitly. The K33 ! component will be treated implicitly. Note that there are some -! cancellations of dxu(i-1+ip) and dyu(jrow-1+jp) +! cancellations of dxu(i-1+ip) and dyu(jrow-1+jp) !----------------------------------------------------------------------- do k=1,nz-1 do j=js_pe,je_pe do i=is_pe,ie_pe - diffloc = K_iso(i,j,k) - sumx = 0. + diffloc = K_iso(i,j,k) + sumx = 0.d0 do ip=0,1 do kr=0,1 sumx = sumx + diffloc*Ai_bx(i,j,k,ip,kr)/cost(j)*(tr(i+ip,j,k+kr,tau) - tr(i-1+ip,j,k+kr,tau)) enddo enddo - sumy = 0. + sumy = 0.d0 do jp=0,1 do kr=0,1 sumy = sumy + diffloc*Ai_by(i,j,k,jp,kr)*cosu(j-1+jp)* (tr(i,j+jp,k+kr,tau)-tr(i,j-1+jp,k+kr,tau)) enddo enddo - flux_top(i,j,k) = sumx/(4*dxt(i)) +sumy/(4*dyt(j)*cost(j) ) + flux_top(i,j,k) = sumx/(4*dxt(i)) +sumy/(4*dyt(j)*cost(j) ) enddo enddo enddo - flux_top(:,:,nz)=0.0 + flux_top(:,:,nz)=0.0d0 !--------------------------------------------------------------------------------- -! add explicit part +! add explicit part !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe,ie_pe @@ -97,9 +97,9 @@ subroutine isoneutral_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) +(flux_north(i,j,:)- flux_north(i,j-1,:))/(cost(j)*dyt(j)) ) enddo enddo - k=1; aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*flux_top(:,:,k)/dzt(k) + k=1; aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*flux_top(:,:,k)/dzt(k) do k=2,nz - aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) + aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) enddo if (istemp) then @@ -114,10 +114,10 @@ subroutine isoneutral_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) enddo enddo !--------------------------------------------------------------------------------- -! add implicit part +! add implicit part !--------------------------------------------------------------------------------- aloc = tr(:,:,:,taup1) - a_tri=0.0;b_tri=0.0; c_tri=0.0; d_tri=0.0; delta=0.0 + a_tri=0.0d0;b_tri=0.0d0; c_tri=0.0d0; d_tri=0.0d0; delta=0.0d0 do j=js_pe,je_pe do i=is_pe,ie_pe ks=kbot(i,j) @@ -125,21 +125,21 @@ subroutine isoneutral_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) do k=ks,nz-1 delta(k) = dt_tracer/dzw(k)*K_33(i,j,k) enddo - delta(nz)=0.0 + delta(nz)=0.0d0 do k=ks+1,nz a_tri(k) = - delta(k-1)/dzt(k) enddo - a_tri(ks)=0.0 + a_tri(ks)=0.0d0 do k=ks+1,nz-1 - b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) + b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) enddo - b_tri(nz) = 1+ delta(nz-1)/dzt(nz) - b_tri(ks) = 1+ delta(ks)/dzt(ks) + b_tri(nz) = 1+ delta(nz-1)/dzt(nz) + b_tri(ks) = 1+ delta(ks)/dzt(ks) do k=ks,nz-1 c_tri(k) = - delta(k)/dzt(k) enddo - c_tri(nz)=0.0 - d_tri(ks:nz)=tr(i,j,ks:nz,taup1) + c_tri(nz)=0.0d0 + d_tri(ks:nz)=tr(i,j,ks:nz,taup1) call solve_tridiag(a_tri(ks:nz),b_tri(ks:nz),c_tri(ks:nz),d_tri(ks:nz),sol(ks:nz),nz-ks+1) tr(i,j,ks:nz,taup1) = sol(ks:nz) endif @@ -165,10 +165,10 @@ if (enable_conserve_energy) then do j=js_pe-onx+1,je_pe+onx-1 do i=is_pe-onx+1,ie_pe+onx-1 fxa = bloc(i,j,k) - aloc(i,j,k) =+0.5*grav/rho_0*( (bloc(i+1,j,k)-fxa)*flux_east(i ,j,k) & + aloc(i,j,k) =+0.5d0*grav/rho_0*( (bloc(i+1,j,k)-fxa)*flux_east(i ,j,k) & +(fxa-bloc(i-1,j,k))*flux_east(i-1,j,k) ) /(dxt(i)*cost(j)) & - +0.5*grav/rho_0*( (bloc(i,j+1,k)-fxa)*flux_north(i,j ,k) & - +(fxa-bloc(i,j-1,k))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) + +0.5d0*grav/rho_0*( (bloc(i,j+1,k)-fxa)*flux_north(i,j ,k) & + +(fxa-bloc(i,j-1,k))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) enddo enddo end do @@ -180,9 +180,9 @@ if (enable_conserve_energy) then ks=kbot(i,j) if (ks>0) then k=ks; P_diss_iso(i,j,k) = P_diss_iso(i,j,k)+ & - 0.5*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) + 0.5d0*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5d0*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - P_diss_iso(i,j,k) = P_diss_iso(i,j,k)+ 0.5*(aloc(i,j,k) +aloc(i,j,k+1)) + P_diss_iso(i,j,k) = P_diss_iso(i,j,k)+ 0.5d0*(aloc(i,j,k) +aloc(i,j,k+1)) enddo k=nz; P_diss_iso(i,j,k) = P_diss_iso(i,j,k)+ aloc(i,j,k) endif @@ -224,12 +224,12 @@ end subroutine isoneutral_diffusion subroutine isoneutral_skew_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) !======================================================================= -! Isopycnal skew diffusion for tracer, -! following functional formulation by Griffies et al +! Isopycnal skew diffusion for tracer, +! following functional formulation by Griffies et al ! Dissipation is calculated and stored in P_diss_skew ! T/S changes are added to dtemp_iso/dsalt_iso !======================================================================= - use main_module + use main_module use isoneutral_module implicit none integer :: is_,ie_,js_,je_,nz_ @@ -242,13 +242,13 @@ subroutine isoneutral_skew_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) real*8 :: fxa,diffloc !----------------------------------------------------------------------- -! construct total isoneutral tracer flux at east face of "T" cells +! construct total isoneutral tracer flux at east face of "T" cells !----------------------------------------------------------------------- do k=1,nz do j=js_pe,je_pe do i=is_pe-1,ie_pe - diffloc =-0.25*(K_gm(i,j,k)+K_gm(i,j,max(1,k-1)) + K_gm(i+1,j,k)+K_gm(i+1,j,max(1,k-1)) ) - sumz = 0. + diffloc =-0.25d0*(K_gm(i,j,k)+K_gm(i,j,max(1,k-1)) + K_gm(i+1,j,k)+K_gm(i+1,j,max(1,k-1)) ) + sumz = 0.d0 do kr=0,1 km1kr = max(k-1+kr,1) kpkr = min(k+kr,nz) @@ -261,13 +261,13 @@ subroutine isoneutral_skew_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) enddo enddo !----------------------------------------------------------------------- -! construct total isoneutral tracer flux at north face of "T" cells +! construct total isoneutral tracer flux at north face of "T" cells !----------------------------------------------------------------------- do k=1,nz do j=js_pe-1,je_pe do i=is_pe,ie_pe - diffloc =-0.25*(K_gm(i,j,k)+K_gm(i,j,max(1,k-1)) + K_gm(i,j+1,k)+K_gm(i,j+1,max(1,k-1)) ) - sumz = 0. + diffloc =-0.25d0*(K_gm(i,j,k)+K_gm(i,j,max(1,k-1)) + K_gm(i,j+1,k)+K_gm(i,j+1,max(1,k-1)) ) + sumz = 0.d0 do kr=0,1 km1kr = max(k-1+kr,1) kpkr = min(k+kr,nz) @@ -281,31 +281,31 @@ subroutine isoneutral_skew_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) enddo !----------------------------------------------------------------------- ! compute the vertical tracer flux "flux_top" containing the K31 -! and K32 components which are to be solved explicitly. +! and K32 components which are to be solved explicitly. !----------------------------------------------------------------------- do k=1,nz-1 do j=js_pe,je_pe do i=is_pe,ie_pe - diffloc = K_gm(i,j,k) - sumx = 0. + diffloc = K_gm(i,j,k) + sumx = 0.d0 do ip=0,1 do kr=0,1 sumx = sumx + diffloc*Ai_bx(i,j,k,ip,kr)/cost(j)*(tr(i+ip,j,k+kr,tau) - tr(i-1+ip,j,k+kr,tau)) enddo enddo - sumy = 0. + sumy = 0.d0 do jp=0,1 do kr=0,1 sumy = sumy + diffloc*Ai_by(i,j,k,jp,kr)*cosu(j-1+jp)* (tr(i,j+jp,k+kr,tau)-tr(i,j-1+jp,k+kr,tau)) enddo enddo - flux_top(i,j,k) = sumx/(4*dxt(i)) +sumy/(4*dyt(j)*cost(j) ) + flux_top(i,j,k) = sumx/(4*dxt(i)) +sumy/(4*dyt(j)*cost(j) ) enddo enddo enddo - flux_top(:,:,nz)=0.0 + flux_top(:,:,nz)=0.0d0 !--------------------------------------------------------------------------------- -! add explicit part +! add explicit part !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe,ie_pe @@ -313,9 +313,9 @@ subroutine isoneutral_skew_diffusion(is_,ie_,js_,je_,nz_,tr,istemp) +(flux_north(i,j,:)- flux_north(i,j-1,:))/(cost(j)*dyt(j)) ) enddo enddo - k=1; aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*flux_top(:,:,k)/dzt(k) + k=1; aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*flux_top(:,:,k)/dzt(k) do k=2,nz - aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) + aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) enddo if (istemp) then @@ -345,10 +345,10 @@ if (enable_conserve_energy) then do j=js_pe-onx+1,je_pe+onx-1 do i=is_pe-onx+1,ie_pe+onx-1 fxa = bloc(i,j,k) - aloc(i,j,k) =+0.5*grav/rho_0*( (bloc(i+1,j,k)-fxa)*flux_east(i ,j,k) & + aloc(i,j,k) =+0.5d0*grav/rho_0*( (bloc(i+1,j,k)-fxa)*flux_east(i ,j,k) & +(fxa-bloc(i-1,j,k))*flux_east(i-1,j,k) ) /(dxt(i)*cost(j)) & - +0.5*grav/rho_0*( (bloc(i,j+1,k)-fxa)*flux_north(i,j ,k) & - +(fxa-bloc(i,j-1,k))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) + +0.5d0*grav/rho_0*( (bloc(i,j+1,k)-fxa)*flux_north(i,j ,k) & + +(fxa-bloc(i,j-1,k))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) enddo enddo end do @@ -360,9 +360,9 @@ if (enable_conserve_energy) then ks=kbot(i,j) if (ks>0) then k=ks; P_diss_skew(i,j,k) = P_diss_skew(i,j,k)+ & - 0.5*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) + 0.5d0*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5d0*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - P_diss_skew(i,j,k) = P_diss_skew(i,j,k)+ 0.5*(aloc(i,j,k) +aloc(i,j,k+1)) + P_diss_skew(i,j,k) = P_diss_skew(i,j,k)+ 0.5d0*(aloc(i,j,k) +aloc(i,j,k+1)) enddo k=nz; P_diss_skew(i,j,k) = P_diss_skew(i,j,k)+ aloc(i,j,k) endif @@ -375,7 +375,7 @@ if (enable_conserve_energy) then do j=js_pe,je_pe do i=is_pe,ie_pe fxa = (-bloc(i,j,k+1) +bloc(i,j,k))/dzw(k) - P_diss_skew(i,j,k) = P_diss_skew(i,j,k) -grav/rho_0*fxa*flux_top(i,j,k)*maskW(i,j,k) + P_diss_skew(i,j,k) = P_diss_skew(i,j,k) -grav/rho_0*fxa*flux_top(i,j,k)*maskW(i,j,k) enddo enddo end do @@ -391,11 +391,11 @@ end subroutine isoneutral_skew_diffusion subroutine isoneutral_diffusion_all(is_,ie_,js_,je_,nz_,tr,istemp) !======================================================================= -! Isopycnal diffusion plus skew diffusion for tracer, -! following functional formulation by Griffies et al +! Isopycnal diffusion plus skew diffusion for tracer, +! following functional formulation by Griffies et al ! Dissipation is calculated and stored in P_diss_iso !======================================================================= - use main_module + use main_module use isoneutral_module implicit none integer :: is_,ie_,js_,je_,nz_ @@ -412,18 +412,18 @@ subroutine isoneutral_diffusion_all(is_,ie_,js_,je_,nz_,tr,istemp) if (enable_skew_diffusion) then aloc = K_gm else - aloc = 0.0 + aloc = 0.0d0 endif !----------------------------------------------------------------------- -! construct total isoneutral tracer flux at east face of "T" cells +! construct total isoneutral tracer flux at east face of "T" cells !----------------------------------------------------------------------- do k=1,nz do j=js_pe,je_pe do i=is_pe-1,ie_pe - diffloc = 0.25*(K_iso(i,j,k)+K_iso(i,j,max(1,k-1)) + K_iso(i+1,j,k)+K_iso(i+1,j,max(1,k-1)) ) & - - 0.25*(aloc(i,j,k)+aloc(i,j,max(1,k-1)) + aloc(i+1,j,k)+aloc(i+1,j,max(1,k-1)) ) - sumz = 0. + diffloc = 0.25d0*(K_iso(i,j,k)+K_iso(i,j,max(1,k-1)) + K_iso(i+1,j,k)+K_iso(i+1,j,max(1,k-1)) ) & + - 0.25d0*(aloc(i,j,k)+aloc(i,j,max(1,k-1)) + aloc(i+1,j,k)+aloc(i+1,j,max(1,k-1)) ) + sumz = 0.d0 do kr=0,1 km1kr = max(k-1+kr,1) kpkr = min(k+kr,nz) @@ -436,14 +436,14 @@ subroutine isoneutral_diffusion_all(is_,ie_,js_,je_,nz_,tr,istemp) enddo enddo !----------------------------------------------------------------------- -! construct total isoneutral tracer flux at north face of "T" cells +! construct total isoneutral tracer flux at north face of "T" cells !----------------------------------------------------------------------- do k=1,nz do j=js_pe-1,je_pe do i=is_pe,ie_pe - diffloc = 0.25*(K_iso(i,j,k)+K_iso(i,j,max(1,k-1)) + K_iso(i,j+1,k)+K_iso(i,j+1,max(1,k-1)) ) & - - 0.25*(aloc(i,j,k)+aloc(i,j,max(1,k-1)) + aloc(i,j+1,k)+aloc(i,j+1,max(1,k-1)) ) - sumz = 0. + diffloc = 0.25d0*(K_iso(i,j,k)+K_iso(i,j,max(1,k-1)) + K_iso(i,j+1,k)+K_iso(i,j+1,max(1,k-1)) ) & + - 0.25d0*(aloc(i,j,k)+aloc(i,j,max(1,k-1)) + aloc(i,j+1,k)+aloc(i,j+1,max(1,k-1)) ) + sumz = 0.d0 do kr=0,1 km1kr = max(k-1+kr,1) kpkr = min(k+kr,nz) @@ -459,31 +459,31 @@ subroutine isoneutral_diffusion_all(is_,ie_,js_,je_,nz_,tr,istemp) ! compute the vertical tracer flux "flux_top" containing the K31 ! and K32 components which are to be solved explicitly. The K33 ! component will be treated implicitly. Note that there are some -! cancellations of dxu(i-1+ip) and dyu(jrow-1+jp) +! cancellations of dxu(i-1+ip) and dyu(jrow-1+jp) !----------------------------------------------------------------------- do k=1,nz-1 do j=js_pe,je_pe do i=is_pe,ie_pe diffloc = K_iso(i,j,k) + aloc(i,j,k) - sumx = 0. + sumx = 0.d0 do ip=0,1 do kr=0,1 sumx = sumx + diffloc*Ai_bx(i,j,k,ip,kr)/cost(j)*(tr(i+ip,j,k+kr,tau) - tr(i-1+ip,j,k+kr,tau)) enddo enddo - sumy = 0. + sumy = 0.d0 do jp=0,1 do kr=0,1 sumy = sumy + diffloc*Ai_by(i,j,k,jp,kr)*cosu(j-1+jp)* (tr(i,j+jp,k+kr,tau)-tr(i,j-1+jp,k+kr,tau)) enddo enddo - flux_top(i,j,k) = sumx/(4*dxt(i)) +sumy/(4*dyt(j)*cost(j) ) + flux_top(i,j,k) = sumx/(4*dxt(i)) +sumy/(4*dyt(j)*cost(j) ) enddo enddo enddo - flux_top(:,:,nz)=0.0 + flux_top(:,:,nz)=0.0d0 !--------------------------------------------------------------------------------- -! add explicit part +! add explicit part !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe,ie_pe @@ -491,9 +491,9 @@ subroutine isoneutral_diffusion_all(is_,ie_,js_,je_,nz_,tr,istemp) +(flux_north(i,j,:)- flux_north(i,j-1,:))/(cost(j)*dyt(j)) ) enddo enddo - k=1; aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*flux_top(:,:,k)/dzt(k) + k=1; aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*flux_top(:,:,k)/dzt(k) do k=2,nz - aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) + aloc(:,:,k)=aloc(:,:,k)+maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) enddo if (istemp) then @@ -508,10 +508,10 @@ subroutine isoneutral_diffusion_all(is_,ie_,js_,je_,nz_,tr,istemp) enddo enddo !--------------------------------------------------------------------------------- -! add implicit part +! add implicit part !--------------------------------------------------------------------------------- aloc = tr(:,:,:,taup1) - a_tri=0.0;b_tri=0.0; c_tri=0.0; d_tri=0.0; delta=0.0 + a_tri=0.0d0;b_tri=0.0d0; c_tri=0.0d0; d_tri=0.0d0; delta=0.0d0 do j=js_pe,je_pe do i=is_pe,ie_pe ks=kbot(i,j) @@ -519,21 +519,21 @@ subroutine isoneutral_diffusion_all(is_,ie_,js_,je_,nz_,tr,istemp) do k=ks,nz-1 delta(k) = dt_tracer/dzw(k)*K_33(i,j,k) enddo - delta(nz)=0.0 + delta(nz)=0.0d0 do k=ks+1,nz a_tri(k) = - delta(k-1)/dzt(k) enddo - a_tri(ks)=0.0 + a_tri(ks)=0.0d0 do k=ks+1,nz-1 - b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) + b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) enddo - b_tri(nz) = 1+ delta(nz-1)/dzt(nz) - b_tri(ks) = 1+ delta(ks)/dzt(ks) + b_tri(nz) = 1+ delta(nz-1)/dzt(nz) + b_tri(ks) = 1+ delta(ks)/dzt(ks) do k=ks,nz-1 c_tri(k) = - delta(k)/dzt(k) enddo - c_tri(nz)=0.0 - d_tri(ks:nz)=tr(i,j,ks:nz,taup1) + c_tri(nz)=0.0d0 + d_tri(ks:nz)=tr(i,j,ks:nz,taup1) call solve_tridiag(a_tri(ks:nz),b_tri(ks:nz),c_tri(ks:nz),d_tri(ks:nz),sol(ks:nz),nz-ks+1) tr(i,j,ks:nz,taup1) = sol(ks:nz) endif @@ -559,10 +559,10 @@ if (enable_conserve_energy) then do j=js_pe-onx+1,je_pe+onx-1 do i=is_pe-onx+1,ie_pe+onx-1 fxa = bloc(i,j,k) - aloc(i,j,k) =+0.5*grav/rho_0*( (bloc(i+1,j,k)-fxa)*flux_east(i ,j,k) & + aloc(i,j,k) =+0.5d0*grav/rho_0*( (bloc(i+1,j,k)-fxa)*flux_east(i ,j,k) & +(fxa-bloc(i-1,j,k))*flux_east(i-1,j,k) ) /(dxt(i)*cost(j)) & - +0.5*grav/rho_0*( (bloc(i,j+1,k)-fxa)*flux_north(i,j ,k) & - +(fxa-bloc(i,j-1,k))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) + +0.5d0*grav/rho_0*( (bloc(i,j+1,k)-fxa)*flux_north(i,j ,k) & + +(fxa-bloc(i,j-1,k))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) enddo enddo end do @@ -574,9 +574,9 @@ if (enable_conserve_energy) then ks=kbot(i,j) if (ks>0) then k=ks; P_diss_iso(i,j,k) = P_diss_iso(i,j,k)+ & - 0.5*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) + 0.5d0*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5d0*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - P_diss_iso(i,j,k) = P_diss_iso(i,j,k)+ 0.5*(aloc(i,j,k) +aloc(i,j,k+1)) + P_diss_iso(i,j,k) = P_diss_iso(i,j,k)+ 0.5d0*(aloc(i,j,k) +aloc(i,j,k+1)) enddo k=nz; P_diss_iso(i,j,k) = P_diss_iso(i,j,k)+ aloc(i,j,k) endif @@ -608,5 +608,3 @@ if (enable_conserve_energy) then endif endif end subroutine isoneutral_diffusion_all - - diff --git a/for_src/isoneutral/isoneutral_friction.f90 b/for_src/isoneutral/isoneutral_friction.f90 index 13d31f7..695008d 100644 --- a/for_src/isoneutral/isoneutral_friction.f90 +++ b/for_src/isoneutral/isoneutral_friction.f90 @@ -6,15 +6,15 @@ subroutine isoneutral_friction !======================================================================= ! vertical friction using TEM formalism for eddy driven velocity !======================================================================= - use main_module - use isoneutral_module - use eke_module + use main_module + use isoneutral_module + use eke_module implicit none integer :: i,j,k,ks real*8 :: a_tri(nz),b_tri(nz),c_tri(nz),d_tri(nz),delta(nz),fxa real*8 :: diss(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) real*8 :: aloc(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) - + if (enable_implicit_vert_friction) then aloc=u(:,:,:,taup1) else @@ -27,23 +27,23 @@ subroutine isoneutral_friction ks=max(kbot(i,j),kbot(i+1,j)) if (ks>0) then do k=ks,nz-1 - fxa = 0.5*(kappa_gm(i,j,k)+kappa_gm(i+1,j,k)) + fxa = 0.5d0*(kappa_gm(i,j,k)+kappa_gm(i+1,j,k)) delta(k) = dt_mom/dzw(k)*fxa*maskU(i,j,k+1)*maskU(i,j,k) enddo - delta(nz)=0.0 - a_tri(ks)=0.0 + delta(nz)=0.0d0 + a_tri(ks)=0.0d0 do k=ks+1,nz a_tri(k) = - delta(k-1)/dzt(k) enddo - b_tri(ks) = 1+ delta(ks)/dzt(ks) + b_tri(ks) = 1+ delta(ks)/dzt(ks) do k=ks+1,nz-1 - b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) + b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) enddo - b_tri(nz) = 1+ delta(nz-1)/dzt(nz) + b_tri(nz) = 1+ delta(nz-1)/dzt(nz) do k=ks,nz-1 c_tri(k) = - delta(k)/dzt(k) enddo - c_tri(nz)=0.0 + c_tri(nz)=0.0d0 d_tri(ks:nz)=aloc(i,j,ks:nz)! A u = d call solve_tridiag(a_tri(ks:nz),b_tri(ks:nz),c_tri(ks:nz),d_tri(ks:nz),u(i,j,ks:nz,taup1),nz-ks+1) du_mix(i,j,ks:nz)=du_mix(i,j,ks:nz)+ (u(i,j,ks:nz,taup1)-aloc(i,j,ks:nz))/dt_mom @@ -52,11 +52,11 @@ subroutine isoneutral_friction enddo if (enable_conserve_energy) then - ! diagnose dissipation + ! diagnose dissipation do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - fxa = 0.5*(kappa_gm(i,j,k)+kappa_gm(i+1,j,k)) + fxa = 0.5d0*(kappa_gm(i,j,k)+kappa_gm(i+1,j,k)) flux_top(i,j,k)=fxa*(u(i,j,k+1,taup1)-u(i,j,k,taup1))/dzw(k)*maskU(i,j,k+1)*maskU(i,j,k) enddo enddo @@ -64,13 +64,13 @@ subroutine isoneutral_friction do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - diss(i,j,k) = (u(i,j,k+1,tau)-u(i,j,k,tau))*flux_top(i,j,k)/dzw(k) + diss(i,j,k) = (u(i,j,k+1,tau)-u(i,j,k,tau))*flux_top(i,j,k)/dzw(k) enddo enddo enddo - diss(:,:,nz)=0.0 + diss(:,:,nz)=0.0d0 call ugrid_to_tgrid(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss,diss) - K_diss_gm = diss + K_diss_gm = diss endif if (enable_implicit_vert_friction) then @@ -85,23 +85,23 @@ subroutine isoneutral_friction ks=max(kbot(i,j),kbot(i,j+1)) if (ks>0) then do k=ks,nz-1 - fxa = 0.5*(kappa_gm(i,j,k)+kappa_gm(i,j+1,k)) + fxa = 0.5d0*(kappa_gm(i,j,k)+kappa_gm(i,j+1,k)) delta(k) = dt_mom/dzw(k)*fxa*maskV(i,j,k+1)*maskV(i,j,k) enddo - delta(nz)=0.0 - a_tri(ks)=0.0 + delta(nz)=0.0d0 + a_tri(ks)=0.0d0 do k=ks+1,nz a_tri(k) = - delta(k-1)/dzt(k) enddo - b_tri(ks) = 1+ delta(ks)/dzt(ks) + b_tri(ks) = 1+ delta(ks)/dzt(ks) do k=ks+1,nz-1 - b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) + b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) enddo - b_tri(nz) = 1+ delta(nz-1)/dzt(nz) + b_tri(nz) = 1+ delta(nz-1)/dzt(nz) do k=ks,nz-1 c_tri(k) = - delta(k)/dzt(k) enddo - c_tri(nz)=0.0 + c_tri(nz)=0.0d0 d_tri(ks:nz)=aloc(i,j,ks:nz) call solve_tridiag(a_tri(ks:nz),b_tri(ks:nz),c_tri(ks:nz),d_tri(ks:nz),v(i,j,ks:nz,taup1),nz-ks+1) dv_mix(i,j,ks:nz)=dv_mix(i,j,ks:nz)+ (v(i,j,ks:nz,taup1)-aloc(i,j,ks:nz))/dt_mom @@ -110,11 +110,11 @@ subroutine isoneutral_friction enddo if (enable_conserve_energy) then - ! diagnose dissipation + ! diagnose dissipation do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - fxa = 0.5*(kappa_gm(i,j,k)+kappa_gm(i,j+1,k)) + fxa = 0.5d0*(kappa_gm(i,j,k)+kappa_gm(i,j+1,k)) flux_top(i,j,k)=fxa*(v(i,j,k+1,taup1)-v(i,j,k,taup1))/dzw(k)*maskV(i,j,k+1)*maskV(i,j,k) enddo enddo @@ -122,15 +122,13 @@ subroutine isoneutral_friction do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - diss(i,j,k) =(v(i,j ,k+1,tau)-v(i,j ,k,tau))*flux_top(i,j ,k)/dzw(k) + diss(i,j,k) =(v(i,j ,k+1,tau)-v(i,j ,k,tau))*flux_top(i,j ,k)/dzw(k) enddo enddo enddo - diss(:,:,nz)=0.0 + diss(:,:,nz)=0.0d0 call vgrid_to_tgrid(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss,diss) - K_diss_gm = K_diss_gm + diss + K_diss_gm = K_diss_gm + diss endif end subroutine isoneutral_friction - - diff --git a/for_src/isoneutral/isoneutral_module.f90 b/for_src/isoneutral/isoneutral_module.f90 index 3c71723..5699095 100644 --- a/for_src/isoneutral/isoneutral_module.f90 +++ b/for_src/isoneutral/isoneutral_module.f90 @@ -16,20 +16,20 @@ module isoneutral_module real*8, allocatable :: K_31(:,:,:) ! isopycnal mixing tensor component real*8, allocatable :: K_32(:,:,:) ! isopycnal mixing tensor component real*8, allocatable :: K_33(:,:,:) ! isopycnal mixing tensor component - real*8, allocatable :: Ai_ez(:,:,:,:,:) ! - real*8, allocatable :: Ai_nz(:,:,:,:,:) ! - real*8, allocatable :: Ai_bx(:,:,:,:,:) ! - real*8, allocatable :: Ai_by(:,:,:,:,:) ! + real*8, allocatable :: Ai_ez(:,:,:,:,:) ! + real*8, allocatable :: Ai_nz(:,:,:,:,:) ! + real*8, allocatable :: Ai_bx(:,:,:,:,:) ! + real*8, allocatable :: Ai_by(:,:,:,:,:) ! real*8, allocatable :: B1_gm(:,:,:) ! zonal streamfunction (for diagnostic purpose only) real*8, allocatable :: B2_gm(:,:,:) ! meridional streamfunction (for diagnostic purpose only) real*8, allocatable :: K_gm(:,:,:) ! GM diffusivity in m^2/s, either constant or from EKE model real*8, allocatable :: kappa_gm(:,:,:) ! vertical viscosity due to skew diffusivity K_gm in m^2/s real*8, allocatable :: K_iso(:,:,:) ! along isopycnal diffusivity in m^2/s - real*8 :: K_iso_0 = 0.0 ! constant for isopycnal diffusivity in m^2/s - real*8 :: K_iso_steep = 0.0 ! lateral diffusivity for steep slopes in m^2/s - real*8 :: K_gm_0 = 0.0 ! fixed value for K_gm which is set for no EKE model - real*8 :: iso_dslope=0.0008 ! parameters controlling max allowed isopycnal slopes - real*8 :: iso_slopec=0.001 ! parameters controlling max allowed isopycnal slopes + real*8 :: K_iso_0 = 0.0d0 ! constant for isopycnal diffusivity in m^2/s + real*8 :: K_iso_steep = 0.0d0 ! lateral diffusivity for steep slopes in m^2/s + real*8 :: K_gm_0 = 0.0d0 ! fixed value for K_gm which is set for no EKE model + real*8 :: iso_dslope=0.0008d0 ! parameters controlling max allowed isopycnal slopes + real*8 :: iso_slopec=0.001d0 ! parameters controlling max allowed isopycnal slopes end module isoneutral_module @@ -59,6 +59,6 @@ subroutine allocate_isoneutral_module allocate( B2_gm(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); B2_gm = 0 allocate( kappa_gm(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); kappa_gm = 0 - allocate( K_gm(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); K_gm = 0.0 - allocate( K_iso(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); K_iso = 0.0 + allocate( K_gm(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); K_gm = 0.0d0 + allocate( K_iso(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); K_iso = 0.0d0 end subroutine allocate_isoneutral_module diff --git a/for_src/main/advection.f90 b/for_src/main/advection.f90 index eda4065..3b8e003 100644 --- a/for_src/main/advection.f90 +++ b/for_src/main/advection.f90 @@ -1,4 +1,4 @@ - + @@ -7,7 +7,7 @@ subroutine adv_flux_2nd(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) !--------------------------------------------------------------------------------- ! 2th order advective tracer flux !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_,nz_ real*8, intent(inout) :: adv_fe(is_:ie_,js_:je_,nz_), adv_fn(is_:ie_,js_:je_,nz_) @@ -17,25 +17,25 @@ subroutine adv_flux_2nd(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) do k=1,nz do j=js_pe,je_pe do i=is_pe-1,ie_pe - adv_fe(i,j,k)=0.5*(var(i,j,k) + var(i+1,j,k) )*u(i,j,k,tau)*maskU(i,j,k) + adv_fe(i,j,k)=0.5d0*(var(i,j,k) + var(i+1,j,k) )*u(i,j,k,tau)*maskU(i,j,k) enddo enddo enddo do k=1,nz do j=js_pe-1,je_pe do i=is_pe,ie_pe - adv_fn(i,j,k)=cosu(j)*0.5*( var(i,j,k) + var(i,j+1,k) )*v(i,j,k,tau)*maskV(i,j,k) + adv_fn(i,j,k)=cosu(j)*0.5d0*( var(i,j,k) + var(i,j+1,k) )*v(i,j,k,tau)*maskV(i,j,k) enddo enddo enddo do k=1,nz-1 do j=js_pe,je_pe do i=is_pe,ie_pe - adv_ft(i,j,k)=0.5*( var(i,j,k) + var(i,j,k+1) )*w(i,j,k,tau)*maskW(i,j,k) + adv_ft(i,j,k)=0.5d0*( var(i,j,k) + var(i,j,k+1) )*w(i,j,k,tau)*maskW(i,j,k) enddo enddo enddo - adv_ft(:,:,nz)=0.0 + adv_ft(:,:,nz)=0.0d0 end subroutine adv_flux_2nd @@ -56,21 +56,21 @@ subroutine adv_flux_superbee(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) ! where the $\psi(C_r)$ is the limiter function and $C_r$ is ! the slope ratio. !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_,nz_ real*8, intent(inout) :: adv_fe(is_:ie_,js_:je_,nz_), adv_fn(is_:ie_,js_:je_,nz_) real*8, intent(inout) :: adv_ft(is_:ie_,js_:je_,nz_), var(is_:ie_,js_:je_,nz_) integer :: i,j,k,km1,kp2 - real*8 :: Rjp,Rj,Rjm,uCFL=0.5,Cr + real*8 :: Rjp,Rj,Rjm,uCFL=0.5d0,Cr ! Statement function to describe flux limiter - ! Upwind Limiter(Cr)=0. - ! Lax-Wendroff Limiter(Cr)=1. - ! Suberbee Limiter(Cr)=max(0.,max(min(1.,2*Cr),min(2.,Cr))) - ! Sweby Limiter(Cr)=max(0.,max(min(1.,1.5*Cr),min(1.5.,Cr))) + ! Upwind Limiter(Cr)=0.d0 + ! Lax-Wendroff Limiter(Cr)=1.d0 + ! Suberbee Limiter(Cr)=max(0.d0,max(min(1.d0,2*Cr),min(2.d0,Cr))) + ! Sweby Limiter(Cr)=max(0.d0,max(min(1.d0,1.5d0*Cr),min(1.5d0.,Cr))) real*8 :: Limiter - Limiter(Cr)=max(0.D0,max(min(1.D0,2.D0*Cr), min(2.D0,Cr))) - ! Limiter(Cr)=max(0.D0,max(min(1.D0,1.5D0*Cr), min(1.5D0,Cr))) + Limiter(Cr)=max(0.D0,max(min(1.D0,2.D0*Cr), min(2.D0,Cr))) + ! Limiter(Cr)=max(0.D0,max(min(1.D0,1.5D0*Cr), min(1.5D0,Cr))) do k=1,nz do j=js_pe,je_pe @@ -79,14 +79,14 @@ subroutine adv_flux_superbee(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) Rjp=(var(i+2,j,k)-var(i+1,j,k))*maskU(i+1,j,k) Rj =(var(i+1,j,k)-var(i ,j,k))*maskU(i ,j,k) Rjm=(var(i ,j,k)-var(i-1,j,k))*maskU(i-1,j,k) - IF (Rj.NE.0.) THEN + IF (Rj.NE.0.d0) THEN IF (u(i,j,k,tau).GT.0) THEN; Cr=Rjm/Rj; ELSE; Cr=Rjp/Rj; ENDIF ELSE - IF (u(i,j,k,tau).GT.0) THEN; Cr=Rjm*1.E20; ELSE; Cr=Rjp*1.E20; ENDIF + IF (u(i,j,k,tau).GT.0) THEN; Cr=Rjm*1.d20; ELSE; Cr=Rjp*1.d20; ENDIF ENDIF Cr=Limiter(Cr) adv_fe(i,j,k) = u(i,j,k,tau)*(var(i+1,j,k)+var(i,j,k))*0.5d0 & - -ABS(u(i,j,k,tau))*((1.-Cr)+uCFL*Cr)*Rj*0.5d0 + -ABS(u(i,j,k,tau))*((1.d0-Cr)+uCFL*Cr)*Rj*0.5d0 enddo enddo enddo @@ -98,18 +98,18 @@ subroutine adv_flux_superbee(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) Rj =(var(i,j+1,k)-var(i,j ,k))*maskV(i,j ,k) Rjm=(var(i,j ,k)-var(i,j-1,k))*maskV(i,j-1,k) uCFL = ABS( cosu(j)*v(i,j,k,tau)*dt_tracer/(cost(j)*dyt(j)) ) - IF (Rj.NE.0.) THEN + IF (Rj.NE.0.d0) THEN IF (v(i,j,k,tau).GT.0) THEN; Cr=Rjm/Rj; ELSE; Cr=Rjp/Rj; ENDIF ELSE - IF (v(i,j,k,tau).GT.0) THEN; Cr=Rjm*1.E20; ELSE; Cr=Rjp*1.E20; ENDIF + IF (v(i,j,k,tau).GT.0) THEN; Cr=Rjm*1.d20; ELSE; Cr=Rjp*1.d20; ENDIF ENDIF Cr=Limiter(Cr) adv_fn(i,j,k) = cosu(j)*v(i,j,k,tau)*(var(i,j+1,k)+var(i,j,k))*0.5d0 & - -ABS(cosu(j)*v(i,j,k,tau))*((1.-Cr)+uCFL*Cr)*Rj*0.5d0 + -ABS(cosu(j)*v(i,j,k,tau))*((1.d0-Cr)+uCFL*Cr)*Rj*0.5d0 enddo enddo enddo - + do k=1,nz-1 kp2=min(nz,k+2); !if (kp2>np) kp2=3 km1=max(1,k-1) !if (km1<1) km1=np-2 @@ -119,18 +119,18 @@ subroutine adv_flux_superbee(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) Rj =(var(i,j,k+1)-var(i,j,k ))*maskW(i,j,k ) Rjm=(var(i,j,k )-var(i,j,km1))*maskW(i,j,km1) uCFL = ABS( w(i,j,k,tau)*dt_tracer/dzt(k) ) - IF (Rj.NE.0.) THEN + IF (Rj.NE.0.d0) THEN IF (w(i,j,k,tau).GT.0) THEN; Cr=Rjm/Rj; ELSE; Cr=Rjp/Rj; ENDIF ELSE - IF (w(i,j,k,tau).GT.0) THEN; Cr=Rjm*1.E20; ELSE; Cr=Rjp*1.E20; ENDIF + IF (w(i,j,k,tau).GT.0) THEN; Cr=Rjm*1.d20; ELSE; Cr=Rjp*1.d20; ENDIF ENDIF Cr=Limiter(Cr) adv_ft(i,j,k) = w(i,j,k,tau)*(var(i,j,k+1)+var(i,j,k))*0.5d0 & - -ABS(w(i,j,k,tau))*((1.-Cr)+uCFL*Cr)*Rj*0.5d0 + -ABS(w(i,j,k,tau))*((1.d0-Cr)+uCFL*Cr)*Rj*0.5d0 enddo enddo enddo - adv_ft(:,:,nz)=0.0 + adv_ft(:,:,nz)=0.0d0 end subroutine adv_flux_superbee @@ -147,17 +147,17 @@ subroutine calculate_velocity_on_wgrid ! lateral advection velocities on W grid do k=1,nz-1 - u_wgrid(:,:,k) = u(:,:,k+1,tau)*maskU(:,:,k+1)*0.5*dzt(k+1)/dzw(k) + u(:,:,k,tau)*maskU(:,:,k)*0.5*dzt(k)/dzw(k) - v_wgrid(:,:,k) = v(:,:,k+1,tau)*maskV(:,:,k+1)*0.5*dzt(k+1)/dzw(k) + v(:,:,k,tau)*maskV(:,:,k)*0.5*dzt(k)/dzw(k) + u_wgrid(:,:,k) = u(:,:,k+1,tau)*maskU(:,:,k+1)*0.5d0*dzt(k+1)/dzw(k) + u(:,:,k,tau)*maskU(:,:,k)*0.5d0*dzt(k)/dzw(k) + v_wgrid(:,:,k) = v(:,:,k+1,tau)*maskV(:,:,k+1)*0.5d0*dzt(k+1)/dzw(k) + v(:,:,k,tau)*maskV(:,:,k)*0.5d0*dzt(k)/dzw(k) enddo k=nz - u_wgrid(:,:,k) = u(:,:,k,tau)*maskU(:,:,k)*0.5*dzt(k)/dzw(k) - v_wgrid(:,:,k) = v(:,:,k,tau)*maskV(:,:,k)*0.5*dzt(k)/dzw(k) + u_wgrid(:,:,k) = u(:,:,k,tau)*maskU(:,:,k)*0.5d0*dzt(k)/dzw(k) + v_wgrid(:,:,k) = v(:,:,k,tau)*maskV(:,:,k)*0.5d0*dzt(k)/dzw(k) ! redirect velocity at bottom and at topography k=1 - u_wgrid(:,:,k) = u_wgrid(:,:,k) + u(:,:,k,tau)*maskU(:,:,k)*0.5*dzt(k)/dzw(k) - v_wgrid(:,:,k) = v_wgrid(:,:,k) + v(:,:,k,tau)*maskV(:,:,k)*0.5*dzt(k)/dzw(k) + u_wgrid(:,:,k) = u_wgrid(:,:,k) + u(:,:,k,tau)*maskU(:,:,k)*0.5d0*dzt(k)/dzw(k) + v_wgrid(:,:,k) = v_wgrid(:,:,k) + v(:,:,k,tau)*maskV(:,:,k)*0.5d0*dzt(k)/dzw(k) do k=1,nz-1 do j=js_pe-onx,je_pe+onx do i=is_pe-onx,ie_pe+onx-1 @@ -198,7 +198,7 @@ subroutine calculate_velocity_on_wgrid ! fxb = fxb + w(i,j,nz,tau) *area_t(i,j) ! enddo ! enddo - ! call global_sum(fxa); call global_sum(fxb); + ! call global_sum(fxa); call global_sum(fxb); ! if (my_pe==0) print'(a,e12.6,a)',' transport at sea surface on t grid = ',fxb,' m^3/s' ! if (my_pe==0) print'(a,e12.6,a)',' transport at sea surface on w grid = ',fxa,' m^3/s' ! @@ -210,7 +210,7 @@ subroutine calculate_velocity_on_wgrid ! fxb = fxb + w(i,j,nz,tau)**2 *area_t(i,j) ! enddo ! enddo -! call global_sum(fxa); call global_sum(fxb); +! call global_sum(fxa); call global_sum(fxb); ! if (my_pe==0) print'(a,e12.6,a)',' w variance on t grid = ',fxb,' (m^3/s)^2' ! if (my_pe==0) print'(a,e12.6,a)',' w variance on w grid = ',fxa,' (m^3/s)^2' ! @@ -227,20 +227,20 @@ subroutine adv_flux_superbee_wgrid(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) !--------------------------------------------------------------------------------- ! Calculates advection of a tracer defined on Wgrid !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_,nz_ real*8, intent(inout) :: adv_fe(is_:ie_,js_:je_,nz_), adv_fn(is_:ie_,js_:je_,nz_) real*8, intent(inout) :: adv_ft(is_:ie_,js_:je_,nz_), var(is_:ie_,js_:je_,nz_) integer :: i,j,k,km1,kp2,kp1 - real*8 :: Rjp,Rj,Rjm,uCFL=0.5,Cr + real*8 :: Rjp,Rj,Rjm,uCFL=0.5d0,Cr ! Statement function to describe flux limiter - ! Upwind Limiter(Cr)=0. - ! Lax-Wendroff Limiter(Cr)=1. - ! Suberbee Limiter(Cr)=max(0.,max(min(1.,2*Cr),min(2.,Cr))) - ! Sweby Limiter(Cr)=max(0.,max(min(1.,1.5*Cr),min(1.5.,Cr))) + ! Upwind Limiter(Cr)=0.d0 + ! Lax-Wendroff Limiter(Cr)=1.d0 + ! Suberbee Limiter(Cr)=max(0.d0,max(min(1.d0,2*Cr),min(2.d0,Cr))) + ! Sweby Limiter(Cr)=max(0.d0,max(min(1.d0,1.5d0*Cr),min(1.5d0.,Cr))) real*8 :: Limiter - Limiter(Cr)=max(0.D0,max(min(1.D0,2.D0*Cr), min(2.D0,Cr))) + Limiter(Cr)=max(0.D0,max(min(1.D0,2.D0*Cr), min(2.D0,Cr))) real*8 :: maskUtr,maskVtr,maskWtr maskUtr(i,j,k) = maskW(i+1,j,k)*maskW(i,j,k) maskVtr(i,j,k) = maskW(i,j+1,k)*maskW(i,j,k) @@ -253,14 +253,14 @@ subroutine adv_flux_superbee_wgrid(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) Rjp=(var(i+2,j,k)-var(i+1,j,k))*maskUtr(i+1,j,k) Rj =(var(i+1,j,k)-var(i ,j,k))*maskUtr(i ,j,k) Rjm=(var(i ,j,k)-var(i-1,j,k))*maskUtr(i-1,j,k) - IF (Rj.NE.0.) THEN + IF (Rj.NE.0.d0) THEN IF (u_wgrid(i,j,k).GT.0) THEN; Cr=Rjm/Rj; ELSE; Cr=Rjp/Rj; ENDIF ELSE - IF (u_wgrid(i,j,k).GT.0) THEN; Cr=Rjm*1.E20; ELSE; Cr=Rjp*1.E20; ENDIF + IF (u_wgrid(i,j,k).GT.0) THEN; Cr=Rjm*1.d20; ELSE; Cr=Rjp*1.d20; ENDIF ENDIF Cr=Limiter(Cr) adv_fe(i,j,k) = u_wgrid(i,j,k)*(var(i+1,j,k)+var(i,j,k))*0.5d0 & - -ABS(u_wgrid(i,j,k))*((1.-Cr)+uCFL*Cr)*Rj*0.5d0 + -ABS(u_wgrid(i,j,k))*((1.d0-Cr)+uCFL*Cr)*Rj*0.5d0 enddo enddo enddo @@ -272,40 +272,40 @@ subroutine adv_flux_superbee_wgrid(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) Rj =(var(i,j+1,k)-var(i,j ,k))*maskVtr(i,j ,k) Rjm=(var(i,j ,k)-var(i,j-1,k))*maskVtr(i,j-1,k) uCFL = ABS( cosu(j)*v_wgrid(i,j,k)*dt_tracer/(cost(j)*dyt(j)) ) - IF (Rj.NE.0.) THEN + IF (Rj.NE.0.d0) THEN IF (v_wgrid(i,j,k).GT.0) THEN; Cr=Rjm/Rj; ELSE; Cr=Rjp/Rj; ENDIF ELSE - IF (v_wgrid(i,j,k).GT.0) THEN; Cr=Rjm*1.E20; ELSE; Cr=Rjp*1.E20; ENDIF + IF (v_wgrid(i,j,k).GT.0) THEN; Cr=Rjm*1.d20; ELSE; Cr=Rjp*1.d20; ENDIF ENDIF Cr=Limiter(Cr) adv_fn(i,j,k) = cosu(j)*v_wgrid(i,j,k)*(var(i,j+1,k)+var(i,j,k))*0.5d0 & - -ABS(cosu(j)*v_wgrid(i,j,k))*((1.-Cr)+uCFL*Cr)*Rj*0.5d0 + -ABS(cosu(j)*v_wgrid(i,j,k))*((1.d0-Cr)+uCFL*Cr)*Rj*0.5d0 enddo enddo enddo - + do k=1,nz-1 - kp1=min(nz-1,k+1) - kp2=min(nz,k+2); - km1=max(1,k-1) + kp1=min(nz-1,k+1) + kp2=min(nz,k+2); + km1=max(1,k-1) do j=js_pe,je_pe do i=is_pe,ie_pe Rjp=(var(i,j,kp2)-var(i,j,k+1))*maskWtr(i,j,kp1) Rj =(var(i,j,k+1)-var(i,j,k ))*maskWtr(i,j,k ) Rjm=(var(i,j,k )-var(i,j,km1))*maskWtr(i,j,km1) uCFL = ABS( w_wgrid(i,j,k)*dt_tracer/dzw(k) ) - IF (Rj.NE.0.) THEN + IF (Rj.NE.0.d0) THEN IF (w_wgrid(i,j,k).GT.0) THEN; Cr=Rjm/Rj; ELSE; Cr=Rjp/Rj; ENDIF ELSE - IF (w_wgrid(i,j,k).GT.0) THEN; Cr=Rjm*1.E20; ELSE; Cr=Rjp*1.E20; ENDIF + IF (w_wgrid(i,j,k).GT.0) THEN; Cr=Rjm*1.d20; ELSE; Cr=Rjp*1.d20; ENDIF ENDIF Cr=Limiter(Cr) adv_ft(i,j,k) = w_wgrid(i,j,k)*(var(i,j,k+1)+var(i,j,k))*0.5d0 & - -ABS(w_wgrid(i,j,k))*((1.-Cr)+uCFL*Cr)*Rj*0.5d0 + -ABS(w_wgrid(i,j,k))*((1.d0-Cr)+uCFL*Cr)*Rj*0.5d0 enddo enddo enddo - adv_ft(:,:,nz)=0.0 + adv_ft(:,:,nz)=0.0d0 end subroutine adv_flux_superbee_wgrid @@ -318,7 +318,7 @@ subroutine adv_flux_upwind_wgrid(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) !--------------------------------------------------------------------------------- ! Calculates advection of a tracer defined on Wgrid !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_,nz_ real*8, intent(inout) :: adv_fe(is_:ie_,js_:je_,nz_), adv_fn(is_:ie_,js_:je_,nz_) @@ -347,7 +347,7 @@ subroutine adv_flux_upwind_wgrid(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) enddo enddo enddo - + do k=1,nz-1 do j=js_pe,je_pe do i=is_pe,ie_pe @@ -356,6 +356,5 @@ subroutine adv_flux_upwind_wgrid(is_,ie_,js_,je_,nz_,adv_fe,adv_fn,adv_ft,var) enddo enddo enddo - adv_ft(:,:,nz)=0.0 + adv_ft(:,:,nz)=0.0d0 end subroutine adv_flux_upwind_wgrid - diff --git a/for_src/main/diffusion.f90 b/for_src/main/diffusion.f90 index 2ca678d..378fd77 100644 --- a/for_src/main/diffusion.f90 +++ b/for_src/main/diffusion.f90 @@ -4,10 +4,10 @@ subroutine tempsalt_biharmonic !--------------------------------------------------------------------------------- -! biharmonic mixing of temp and salinity, +! biharmonic mixing of temp and salinity, ! dissipation of dyn. Enthalpy is stored !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer :: i,j,k,ks,is,ie,js,je real*8 :: aloc(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) @@ -23,16 +23,16 @@ subroutine tempsalt_biharmonic enddo do j=js,je-1 flux_north(:,j,:)=-fxa*(temp(:,j+1,:,tau)-temp(:,j,:,tau))/dyu(j)*maskV(:,j,:)*cosu(j) - enddo - flux_east(ie,:,:)=0.; flux_north(:,je,:)=0. + enddo + flux_east(ie,:,:)=0.d0; flux_north(:,je,:)=0.d0 do j=js+1,je do i=is+1,ie del2(i,j,:)= maskT(i,j,:)* (flux_east(i,j,:) - flux_east(i-1,j,:))/(cost(j)*dxt(i)) & - +(flux_north(i,j,:) - flux_north(i,j-1,:))/(cost(j)*dyt(j)) + +(flux_north(i,j,:) - flux_north(i,j-1,:))/(cost(j)*dyt(j)) enddo enddo - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,del2) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,del2) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,del2) do j=js,je @@ -42,14 +42,14 @@ subroutine tempsalt_biharmonic enddo do j=js,je-1 flux_north(:,j,:)=fxa*(del2(:,j+1,:)-del2(:,j,:))/dyu(j)*maskV(:,j,:)*cosu(j) - enddo - flux_east(ie,:,:)=0.; flux_north(:,je,:)=0. + enddo + flux_east(ie,:,:)=0.d0; flux_north(:,je,:)=0.d0 - ! update tendency + ! update tendency do j=js_pe-onx+1,je_pe+onx do i=is_pe-onx+1,ie_pe+onx dtemp_hmix(i,j,:)= + maskT(i,j,:)* (flux_east(i,j,:) - flux_east(i-1,j,:))/(cost(j)*dxt(i)) & - +(flux_north(i,j,:) - flux_north(i,j-1,:))/(cost(j)*dyt(j)) + +(flux_north(i,j,:) - flux_north(i,j-1,:))/(cost(j)*dyt(j)) enddo enddo temp(:,:,:,taup1)=temp(:,:,:,taup1)+dt_tracer*dtemp_hmix*maskT @@ -60,10 +60,10 @@ if (enable_conserve_energy) then do j=js_pe,je_pe do i=is_pe,ie_pe fxa = int_drhodT(i,j,k,tau) - aloc(i,j,k) =+0.5*grav/rho_0*( (int_drhodT(i+1,j,k,tau)-fxa)*flux_east(i ,j,k) & + aloc(i,j,k) =+0.5d0*grav/rho_0*( (int_drhodT(i+1,j,k,tau)-fxa)*flux_east(i ,j,k) & +(fxa-int_drhodT(i-1,j,k,tau))*flux_east(i-1,j,k) ) /(dxt(i)*cost(j)) & - +0.5*grav/rho_0*( (int_drhodT(i,j+1,k,tau)-fxa)*flux_north(i,j ,k) & - +(fxa-int_drhodT(i,j-1,k,tau))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) + +0.5d0*grav/rho_0*( (int_drhodT(i,j+1,k,tau)-fxa)*flux_north(i,j ,k) & + +(fxa-int_drhodT(i,j-1,k,tau))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) enddo enddo end do @@ -72,9 +72,9 @@ if (enable_conserve_energy) then do i=is_pe,ie_pe ks=kbot(i,j) if (ks>0) then - k=ks; P_diss_hmix(i,j,k) = 0.5*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) + k=ks; P_diss_hmix(i,j,k) = 0.5d0*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5d0*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - P_diss_hmix(i,j,k) = 0.5*(aloc(i,j,k) +aloc(i,j,k+1)) + P_diss_hmix(i,j,k) = 0.5d0*(aloc(i,j,k) +aloc(i,j,k+1)) enddo k=nz; P_diss_hmix(i,j,k) = aloc(i,j,k) endif @@ -91,16 +91,16 @@ endif enddo do j=js,je-1 flux_north(:,j,:)=-fxa*(salt(:,j+1,:,tau)-salt(:,j,:,tau))/dyu(j)*maskV(:,j,:)*cosu(j) - enddo - flux_east(ie,:,:)=0.; flux_north(:,je,:)=0. + enddo + flux_east(ie,:,:)=0.d0; flux_north(:,je,:)=0.d0 do j=js+1,je do i=is+1,ie del2(i,j,:)= maskT(i,j,:)* (flux_east(i,j,:) - flux_east(i-1,j,:))/(cost(j)*dxt(i)) & - +(flux_north(i,j,:) - flux_north(i,j-1,:))/(cost(j)*dyt(j)) + +(flux_north(i,j,:) - flux_north(i,j-1,:))/(cost(j)*dyt(j)) enddo enddo - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,del2) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,del2) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,del2) do j=js,je @@ -110,14 +110,14 @@ endif enddo do j=js,je-1 flux_north(:,j,:)=fxa*(del2(:,j+1,:)-del2(:,j,:))/dyu(j)*maskV(:,j,:)*cosu(j) - enddo - flux_east(ie,:,:)=0.; flux_north(:,je,:)=0. + enddo + flux_east(ie,:,:)=0.d0; flux_north(:,je,:)=0.d0 - ! update tendency + ! update tendency do j=js_pe-onx+1,je_pe+onx do i=is_pe-onx+1,ie_pe+onx dsalt_hmix(i,j,:)= + maskT(i,j,:)* (flux_east(i,j,:) - flux_east(i-1,j,:))/(cost(j)*dxt(i)) & - +(flux_north(i,j,:) - flux_north(i,j-1,:))/(cost(j)*dyt(j)) + +(flux_north(i,j,:) - flux_north(i,j-1,:))/(cost(j)*dyt(j)) enddo enddo salt(:,:,:,taup1)=salt(:,:,:,taup1)+dt_tracer*dsalt_hmix*maskT @@ -129,10 +129,10 @@ if (enable_conserve_energy) then do j=js_pe-onx+1,je_pe+onx-1 do i=is_pe-onx+1,ie_pe+onx-1 fxa = int_drhodS(i,j,k,tau) - aloc(i,j,k) =+0.5*grav/rho_0*( (int_drhodS(i+1,j,k,tau)-fxa)*flux_east(i ,j,k) & + aloc(i,j,k) =+0.5d0*grav/rho_0*( (int_drhodS(i+1,j,k,tau)-fxa)*flux_east(i ,j,k) & +(fxa-int_drhodS(i-1,j,k,tau))*flux_east(i-1,j,k) ) /(dxt(i)*cost(j)) & - +0.5*grav/rho_0*( (int_drhodS(i,j+1,k,tau)-fxa)*flux_north(i,j ,k) & - +(fxa-int_drhodS(i,j-1,k,tau))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) + +0.5d0*grav/rho_0*( (int_drhodS(i,j+1,k,tau)-fxa)*flux_north(i,j ,k) & + +(fxa-int_drhodS(i,j-1,k,tau))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) enddo enddo end do @@ -142,9 +142,9 @@ if (enable_conserve_energy) then ks=kbot(i,j) if (ks>0) then k=ks; P_diss_hmix(i,j,k) = P_diss_hmix(i,j,k)+ & - 0.5*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) + 0.5d0*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5d0*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - P_diss_hmix(i,j,k) = P_diss_hmix(i,j,k)+ 0.5*(aloc(i,j,k) +aloc(i,j,k+1)) + P_diss_hmix(i,j,k) = P_diss_hmix(i,j,k)+ 0.5d0*(aloc(i,j,k) +aloc(i,j,k+1)) enddo k=nz; P_diss_hmix(i,j,k) = P_diss_hmix(i,j,k)+ aloc(i,j,k) endif @@ -158,10 +158,10 @@ end subroutine tempsalt_biharmonic subroutine tempsalt_diffusion !--------------------------------------------------------------------------------- -! Diffusion of temp and salinity, +! Diffusion of temp and salinity, ! dissipation of dyn. Enthalpy is stored !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer :: i,j,k,ks real*8 :: fxa @@ -173,11 +173,11 @@ subroutine tempsalt_diffusion flux_east(i,j,:)=K_h*(temp(i+1,j,:,tau)-temp(i,j,:,tau))/(cost(j)*dxu(i))*maskU(i,j,:) enddo enddo - flux_east(ie_pe+onx,:,:)=0. + flux_east(ie_pe+onx,:,:)=0.d0 do j=js_pe-onx,je_pe+onx-1 flux_north(:,j,:)=K_h*(temp(:,j+1,:,tau)-temp(:,j,:,tau))/dyu(j)*maskV(:,j,:)*cosu(j) enddo - flux_north(:,je_pe+onx,:)=0. + flux_north(:,je_pe+onx,:)=0.d0 if (enable_hor_friction_cos_scaling) then do j=js_pe-onx,je_pe+onx @@ -201,10 +201,10 @@ if (enable_conserve_energy) then do j=js_pe-onx+1,je_pe+onx-1 do i=is_pe-onx+1,ie_pe+onx-1 fxa = int_drhodT(i,j,k,tau) - aloc(i,j,k) =+0.5*grav/rho_0*( (int_drhodT(i+1,j,k,tau)-fxa)*flux_east(i ,j,k) & + aloc(i,j,k) =+0.5d0*grav/rho_0*( (int_drhodT(i+1,j,k,tau)-fxa)*flux_east(i ,j,k) & +(fxa-int_drhodT(i-1,j,k,tau))*flux_east(i-1,j,k) ) /(dxt(i)*cost(j)) & - +0.5*grav/rho_0*( (int_drhodT(i,j+1,k,tau)-fxa)*flux_north(i,j ,k) & - +(fxa-int_drhodT(i,j-1,k,tau))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) + +0.5d0*grav/rho_0*( (int_drhodT(i,j+1,k,tau)-fxa)*flux_north(i,j ,k) & + +(fxa-int_drhodT(i,j-1,k,tau))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) enddo enddo end do @@ -213,9 +213,9 @@ if (enable_conserve_energy) then do i=is_pe-onx,ie_pe+onx ks=kbot(i,j) if (ks>0) then - k=ks; P_diss_hmix(i,j,k) = 0.5*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) + k=ks; P_diss_hmix(i,j,k) = 0.5d0*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5d0*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - P_diss_hmix(i,j,k) = 0.5*(aloc(i,j,k) +aloc(i,j,k+1)) + P_diss_hmix(i,j,k) = 0.5d0*(aloc(i,j,k) +aloc(i,j,k+1)) enddo k=nz; P_diss_hmix(i,j,k) = aloc(i,j,k) endif @@ -229,11 +229,11 @@ endif flux_east(i,j,:)=K_h*(salt(i+1,j,:,tau)-salt(i,j,:,tau))/(cost(j)*dxu(i))*maskU(i,j,:) enddo enddo - flux_east(ie_pe+onx,:,:)=0. + flux_east(ie_pe+onx,:,:)=0.d0 do j=js_pe-onx,je_pe+onx-1 flux_north(:,j,:)=K_h*(salt(:,j+1,:,tau)-salt(:,j,:,tau))/dyu(j)*maskV(:,j,:)*cosu(j) enddo - flux_north(:,je_pe+onx,:)=0. + flux_north(:,je_pe+onx,:)=0.d0 if (enable_hor_friction_cos_scaling) then do j=js_pe-onx,je_pe+onx @@ -257,10 +257,10 @@ if (enable_conserve_energy) then do j=js_pe-onx+1,je_pe+onx-1 do i=is_pe-onx+1,ie_pe+onx-1 fxa = int_drhodS(i,j,k,tau) - aloc(i,j,k) =+0.5*grav/rho_0*( (int_drhodS(i+1,j,k,tau)-fxa)*flux_east(i ,j,k) & + aloc(i,j,k) =+0.5d0*grav/rho_0*( (int_drhodS(i+1,j,k,tau)-fxa)*flux_east(i ,j,k) & +(fxa-int_drhodS(i-1,j,k,tau))*flux_east(i-1,j,k) ) /(dxt(i)*cost(j)) & - +0.5*grav/rho_0*( (int_drhodS(i,j+1,k,tau)-fxa)*flux_north(i,j ,k) & - +(fxa-int_drhodS(i,j-1,k,tau))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) + +0.5d0*grav/rho_0*( (int_drhodS(i,j+1,k,tau)-fxa)*flux_north(i,j ,k) & + +(fxa-int_drhodS(i,j-1,k,tau))*flux_north(i,j-1,k) ) /(dyt(j)*cost(j)) enddo enddo end do @@ -270,9 +270,9 @@ if (enable_conserve_energy) then ks=kbot(i,j) if (ks>0) then k=ks; P_diss_hmix(i,j,k) = P_diss_hmix(i,j,k)+ & - 0.5*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) + 0.5d0*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5d0*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - P_diss_hmix(i,j,k) = P_diss_hmix(i,j,k)+ 0.5*(aloc(i,j,k) +aloc(i,j,k+1)) + P_diss_hmix(i,j,k) = P_diss_hmix(i,j,k)+ 0.5d0*(aloc(i,j,k) +aloc(i,j,k+1)) enddo k=nz; P_diss_hmix(i,j,k) = P_diss_hmix(i,j,k)+ aloc(i,j,k) endif @@ -290,10 +290,10 @@ end subroutine subroutine tempsalt_sources !--------------------------------------------------------------------------------- -! Sources of temp and salinity, +! Sources of temp and salinity, ! effect on dyn. Enthalpy is stored !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer :: i,j,k,ks real*8 :: aloc(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) @@ -302,7 +302,7 @@ subroutine tempsalt_sources salt(:,:,:,taup1)=salt(:,:,:,taup1)+dt_tracer*salt_source*maskT if (enable_conserve_energy) then - ! diagnose effect on dynamic enthalpy + ! diagnose effect on dynamic enthalpy do k=1,nz do j=js_pe-onx+1,je_pe+onx-1 do i=is_pe-onx+1,ie_pe+onx-1 @@ -316,9 +316,9 @@ subroutine tempsalt_sources do i=is_pe-onx,ie_pe+onx ks=kbot(i,j) if (ks>0) then - k=ks; P_diss_sources(i,j,k) = 0.5*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) + k=ks; P_diss_sources(i,j,k) = 0.5d0*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5d0*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - P_diss_sources(i,j,k) = 0.5*(aloc(i,j,k) +aloc(i,j,k+1)) + P_diss_sources(i,j,k) = 0.5d0*(aloc(i,j,k) +aloc(i,j,k+1)) enddo k=nz; P_diss_sources(i,j,k) = aloc(i,j,k) endif @@ -326,9 +326,3 @@ subroutine tempsalt_sources enddo endif end subroutine - - - - - - diff --git a/for_src/main/friction.f90 b/for_src/main/friction.f90 index 3098f27..be0c02b 100644 --- a/for_src/main/friction.f90 +++ b/for_src/main/friction.f90 @@ -7,18 +7,18 @@ subroutine explicit_vert_friction ! explicit vertical friction ! dissipation is calculated and added to K_diss_v !======================================================================= - use main_module + use main_module implicit none integer :: i,j,k real*8 :: diss(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz),fxa - + !--------------------------------------------------------------------------------- ! vertical friction of zonal momentum !--------------------------------------------------------------------------------- do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - fxa = 0.5*(kappaM(i,j,k)+kappaM(i+1,j,k)) + fxa = 0.5d0*(kappaM(i,j,k)+kappaM(i+1,j,k)) flux_top(i,j,k)=fxa*(u(i,j,k+1,tau)-u(i,j,k,tau))/dzw(k)*maskU(i,j,k+1)*maskU(i,j,k) enddo enddo @@ -30,18 +30,18 @@ subroutine explicit_vert_friction enddo !--------------------------------------------------------------------------------- - ! diagnose dissipation by vertical friction of zonal momentum + ! diagnose dissipation by vertical friction of zonal momentum !--------------------------------------------------------------------------------- do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - diss(i,j,k) = (u(i,j,k+1,tau)-u(i,j,k,tau))*flux_top(i,j,k)/dzw(k) + diss(i,j,k) = (u(i,j,k+1,tau)-u(i,j,k,tau))*flux_top(i,j,k)/dzw(k) enddo enddo enddo - diss(:,:,nz)=0.0 + diss(:,:,nz)=0.0d0 call ugrid_to_tgrid(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss,diss) - K_diss_v = K_diss_v + diss + K_diss_v = K_diss_v + diss !--------------------------------------------------------------------------------- ! vertical friction of meridional momentum @@ -49,7 +49,7 @@ subroutine explicit_vert_friction do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - fxa = 0.5*(kappaM(i,j,k)+kappaM(i,j+1,k)) + fxa = 0.5d0*(kappaM(i,j,k)+kappaM(i,j+1,k)) flux_top(i,j,k)=fxa*(v(i,j,k+1,tau)-v(i,j,k,tau))/dzw(k)*maskV(i,j,k+1)*maskV(i,j,k) enddo enddo @@ -66,13 +66,13 @@ subroutine explicit_vert_friction do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - diss(i,j,k) = (v(i,j,k+1,tau)-v(i,j,k,tau))*flux_top(i,j,k)/dzw(k) + diss(i,j,k) = (v(i,j,k+1,tau)-v(i,j,k,tau))*flux_top(i,j,k)/dzw(k) enddo enddo enddo - diss(:,:,nz)=0.0 + diss(:,:,nz)=0.0d0 call vgrid_to_tgrid(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss,diss) - K_diss_v = K_diss_v + diss + K_diss_v = K_diss_v + diss if (.not.enable_hydrostatic) then !--------------------------------------------------------------------------------- @@ -81,7 +81,7 @@ subroutine explicit_vert_friction do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - fxa = 0.5*(kappaM(i,j,k)+kappaM(i,j,k+1)) + fxa = 0.5d0*(kappaM(i,j,k)+kappaM(i,j,k+1)) flux_top(i,j,k)=fxa*(w(i,j,k+1,tau)-w(i,j,k,tau))/dzt(k+1)*maskW(i,j,k+1)*maskW(i,j,k) enddo enddo @@ -110,12 +110,12 @@ subroutine implicit_vert_friction ! vertical friction ! dissipation is calculated and added to K_diss_v !======================================================================= - use main_module + use main_module implicit none integer :: i,j,k,ks real*8 :: a_tri(nz),b_tri(nz),c_tri(nz),d_tri(nz),delta(nz),fxa real*8 :: diss(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) - + !--------------------------------------------------------------------------------- ! implicit vertical friction of zonal momentum !--------------------------------------------------------------------------------- @@ -124,24 +124,24 @@ subroutine implicit_vert_friction ks=max(kbot(i,j),kbot(i+1,j)) if (ks>0) then do k=ks,nz-1 - fxa = 0.5*(kappaM(i,j,k)+kappaM(i+1,j,k)) + fxa = 0.5d0*(kappaM(i,j,k)+kappaM(i+1,j,k)) delta(k) = dt_mom/dzw(k)*fxa*maskU(i,j,k+1)*maskU(i,j,k) enddo - delta(nz)=0.0 - a_tri(ks)=0.0 + delta(nz)=0.0d0 + a_tri(ks)=0.0d0 do k=ks+1,nz a_tri(k) = - delta(k-1)/dzt(k) enddo - b_tri(ks) = 1+ delta(ks)/dzt(ks) + b_tri(ks) = 1+ delta(ks)/dzt(ks) do k=ks+1,nz-1 - b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) + b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) enddo - b_tri(nz) = 1+ delta(nz-1)/dzt(nz) + b_tri(nz) = 1+ delta(nz-1)/dzt(nz) do k=ks,nz-1 c_tri(k) = - delta(k)/dzt(k) enddo - c_tri(nz)=0.0 - d_tri(ks:nz)=u(i,j,ks:nz,tau) + c_tri(nz)=0.0d0 + d_tri(ks:nz)=u(i,j,ks:nz,tau) call solve_tridiag(a_tri(ks:nz),b_tri(ks:nz),c_tri(ks:nz),d_tri(ks:nz),u(i,j,ks:nz,taup1),nz-ks+1) endif du_mix(i,j,:)=(u(i,j,:,taup1)-u(i,j,:,tau))/dt_mom @@ -149,12 +149,12 @@ subroutine implicit_vert_friction enddo !--------------------------------------------------------------------------------- - ! diagnose dissipation by vertical friction of zonal momentum + ! diagnose dissipation by vertical friction of zonal momentum !--------------------------------------------------------------------------------- do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - fxa = 0.5*(kappaM(i,j,k)+kappaM(i+1,j,k)) + fxa = 0.5d0*(kappaM(i,j,k)+kappaM(i+1,j,k)) flux_top(i,j,k)=fxa*(u(i,j,k+1,taup1)-u(i,j,k,taup1))/dzw(k)*maskU(i,j,k+1)*maskU(i,j,k) enddo enddo @@ -162,13 +162,13 @@ subroutine implicit_vert_friction do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - diss(i,j,k) = (u(i ,j,k+1,tau)-u(i ,j,k,tau))*flux_top(i ,j,k)/dzw(k) + diss(i,j,k) = (u(i ,j,k+1,tau)-u(i ,j,k,tau))*flux_top(i ,j,k)/dzw(k) enddo enddo enddo - diss(:,:,nz)=0.0 + diss(:,:,nz)=0.0d0 call ugrid_to_tgrid(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss,diss) - K_diss_v = K_diss_v + diss + K_diss_v = K_diss_v + diss !--------------------------------------------------------------------------------- ! implicit vertical friction of meridional momentum @@ -178,24 +178,24 @@ subroutine implicit_vert_friction ks=max(kbot(i,j),kbot(i,j+1)) if (ks>0) then do k=ks,nz-1 - fxa = 0.5*(kappaM(i,j,k)+kappaM(i,j+1,k)) + fxa = 0.5d0*(kappaM(i,j,k)+kappaM(i,j+1,k)) delta(k) = dt_mom/dzw(k)*fxa*maskV(i,j,k+1)*maskV(i,j,k) enddo - delta(nz)=0.0 - a_tri(ks)=0.0 + delta(nz)=0.0d0 + a_tri(ks)=0.0d0 do k=ks+1,nz a_tri(k) = - delta(k-1)/dzt(k) enddo - b_tri(ks) = 1+ delta(ks)/dzt(ks) + b_tri(ks) = 1+ delta(ks)/dzt(ks) do k=ks+1,nz-1 - b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) + b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) enddo - b_tri(nz) = 1+ delta(nz-1)/dzt(nz) + b_tri(nz) = 1+ delta(nz-1)/dzt(nz) do k=ks,nz-1 c_tri(k) = - delta(k)/dzt(k) enddo - c_tri(nz)=0.0 - d_tri(ks:nz)=v(i,j,ks:nz,tau) + c_tri(nz)=0.0d0 + d_tri(ks:nz)=v(i,j,ks:nz,tau) call solve_tridiag(a_tri(ks:nz),b_tri(ks:nz),c_tri(ks:nz),d_tri(ks:nz),v(i,j,ks:nz,taup1),nz-ks+1) endif dv_mix(i,j,:)=(v(i,j,:,taup1)-v(i,j,:,tau))/dt_mom @@ -208,7 +208,7 @@ subroutine implicit_vert_friction do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - fxa = 0.5*(kappaM(i,j,k)+kappaM(i,j+1,k)) + fxa = 0.5d0*(kappaM(i,j,k)+kappaM(i,j+1,k)) flux_top(i,j,k)=fxa*(v(i,j,k+1,taup1)-v(i,j,k,taup1))/dzw(k)*maskV(i,j,k+1)*maskV(i,j,k) enddo enddo @@ -216,13 +216,13 @@ subroutine implicit_vert_friction do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - diss(i,j,k) = (v(i,j,k+1,tau)-v(i,j,k,tau))*flux_top(i,j,k)/dzw(k) + diss(i,j,k) = (v(i,j,k+1,tau)-v(i,j,k,tau))*flux_top(i,j,k)/dzw(k) enddo enddo enddo - diss(:,:,nz)=0.0 + diss(:,:,nz)=0.0d0 call vgrid_to_tgrid(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss,diss) - K_diss_v = K_diss_v + diss + K_diss_v = K_diss_v + diss if (.not.enable_hydrostatic) then !if (my_pe==0) print'(/a/)','ERROR: implicit vertical friction for vertical velocity not implemented' @@ -233,24 +233,24 @@ subroutine implicit_vert_friction ks=kbot(i,j) if (ks>0) then do k=ks,nz-1 - delta(k) = dt_mom/dzt(k+1)*0.5*(kappaM(i,j,k)+kappaM(i,j,k+1)) + delta(k) = dt_mom/dzt(k+1)*0.5d0*(kappaM(i,j,k)+kappaM(i,j,k+1)) enddo - delta(nz)=0.0 + delta(nz)=0.0d0 do k=ks+1,nz-1 a_tri(k) = - delta(k-1)/dzw(k) enddo - a_tri(ks)=0.0 - a_tri(nz) = - delta(nz-1)/(0.5*dzw(nz)) + a_tri(ks)=0.0d0 + a_tri(nz) = - delta(nz-1)/(0.5d0*dzw(nz)) do k=ks+1,nz-1 - b_tri(k) = 1+ delta(k)/dzw(k) + delta(k-1)/dzw(k) + b_tri(k) = 1+ delta(k)/dzw(k) + delta(k-1)/dzw(k) enddo - b_tri(nz) = 1+ delta(nz-1)/(0.5*dzw(nz)) - b_tri(ks) = 1+ delta(ks)/dzw(ks) + b_tri(nz) = 1+ delta(nz-1)/(0.5d0*dzw(nz)) + b_tri(ks) = 1+ delta(ks)/dzw(ks) do k=ks,nz-1 c_tri(k) = - delta(k)/dzw(k) enddo - c_tri(nz)=0.0 - d_tri(ks:nz)=w(i,j,ks:nz,tau) + c_tri(nz)=0.0d0 + d_tri(ks:nz)=w(i,j,ks:nz,tau) call solve_tridiag(a_tri(ks:nz),b_tri(ks:nz),c_tri(ks:nz),d_tri(ks:nz),w(i,j,ks:nz,taup1),nz-ks+1) endif dw_mix(i,j,:)=(w(i,j,:,taup1)-w(i,j,:,tau))/dt_mom @@ -263,7 +263,7 @@ subroutine implicit_vert_friction do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - fxa = 0.5*(kappaM(i,j,k)+kappaM(i,j,k+1)) + fxa = 0.5d0*(kappaM(i,j,k)+kappaM(i,j,k+1)) flux_top(i,j,k)=fxa*(w(i,j,k+1,taup1)-w(i,j,k,taup1))/dzt(k+1)*maskW(i,j,k+1)*maskW(i,j,k) enddo enddo @@ -271,12 +271,12 @@ subroutine implicit_vert_friction do k=1,nz-1 do j=js_pe-1,je_pe do i=is_pe-1,ie_pe - diss(i,j,k) = (w(i,j,k+1,tau)-w(i,j,k,tau))*flux_top(i,j,k)/dzt(k+1) + diss(i,j,k) = (w(i,j,k+1,tau)-w(i,j,k,tau))*flux_top(i,j,k)/dzt(k+1) enddo enddo enddo - diss(:,:,nz)=0.0 - K_diss_v = K_diss_v + diss + diss(:,:,nz)=0.0d0 + K_diss_v = K_diss_v + diss endif @@ -287,10 +287,10 @@ end subroutine implicit_vert_friction subroutine rayleigh_friction !======================================================================= -! interior Rayleigh friction +! interior Rayleigh friction ! dissipation is calculated and added to K_diss_bot !======================================================================= - use main_module + use main_module implicit none integer :: k real*8 :: diss(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) @@ -328,10 +328,10 @@ end subroutine rayleigh_friction subroutine linear_bottom_friction !======================================================================= -! linear bottom friction +! linear bottom friction ! dissipation is calculated and added to K_diss_bot !======================================================================= - use main_module + use main_module implicit none integer :: i,j,k real*8 :: diss(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) @@ -348,7 +348,7 @@ subroutine linear_bottom_friction enddo enddo if (enable_conserve_energy) then - diss=0.0 + diss=0.0d0 do j=js_pe,je_pe do i=is_pe-1,ie_pe k=max(kbot(i,j),kbot(i+1,j)) @@ -365,7 +365,7 @@ subroutine linear_bottom_friction enddo enddo if (enable_conserve_energy) then - diss=0.0 + diss=0.0d0 do j=js_pe-1,je_pe do i=is_pe,ie_pe k=max(kbot(i,j+1),kbot(i,j)) @@ -386,7 +386,7 @@ subroutine linear_bottom_friction enddo enddo if (enable_conserve_energy) then - diss=0.0 + diss=0.0d0 do j=js_pe,je_pe do i=is_pe-1,ie_pe k=max(kbot(i,j),kbot(i+1,j)) @@ -395,7 +395,7 @@ subroutine linear_bottom_friction enddo call calc_diss(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss,K_diss_bot,'U') endif - + do j=js_pe-1,je_pe do i=is_pe,ie_pe k=max(kbot(i,j+1),kbot(i,j)) @@ -403,7 +403,7 @@ subroutine linear_bottom_friction enddo enddo if (enable_conserve_energy) then - diss=0.0 + diss=0.0d0 do j=js_pe-1,je_pe do i=is_pe,ie_pe k=max(kbot(i,j+1),kbot(i,j)) @@ -426,10 +426,10 @@ end subroutine linear_bottom_friction subroutine quadratic_bottom_friction !======================================================================= -! quadratic bottom friction +! quadratic bottom friction ! dissipation is calculated and added to K_diss_bot !======================================================================= - use main_module + use main_module implicit none integer :: i,j,k real*8 :: diss(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz),fxa @@ -437,14 +437,14 @@ subroutine quadratic_bottom_friction ! we might want to account for EKE in the drag, also a tidal residual - aloc=0.0 + aloc=0.0d0 do j=js_pe,je_pe do i=is_pe-1,ie_pe k=max(kbot(i,j),kbot(i+1,j)) if (k>0) then fxa = maskV(i ,j,k)*v(i ,j,k,tau)**2 + maskV(i ,j-1,k)*v(i ,j-1,k,tau)**2 fxa = fxa + maskV(i+1,j,k)*v(i+1,j,k,tau)**2 + maskV(i+1,j-1,k)*v(i+1,j-1,k,tau)**2 - fxa = sqrt(u(i,j,k,tau)**2+ 0.25*fxa ) + fxa = sqrt(u(i,j,k,tau)**2+ 0.25d0*fxa ) aloc(i,j) = maskU(i,j,k)*r_quad_bot*u(i,j,k,tau)*fxa/dzt(k) du_mix(i,j,k) = du_mix(i,j,k) - aloc(i,j) endif @@ -452,7 +452,7 @@ subroutine quadratic_bottom_friction enddo if (enable_conserve_energy) then - diss=0.0 + diss=0.0d0 do j=js_pe,je_pe do i=is_pe-1,ie_pe k=max(kbot(i,j),kbot(i+1,j)) @@ -461,15 +461,15 @@ subroutine quadratic_bottom_friction enddo call calc_diss(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss,K_diss_bot,'U') endif - - aloc=0.0 + + aloc=0.0d0 do j=js_pe-1,je_pe do i=is_pe,ie_pe k=max(kbot(i,j+1),kbot(i,j)) if (k>0) then fxa = maskU(i,j ,k)*u(i,j ,k,tau)**2 + maskU(i-1,j ,k)*u(i-1,j ,k,tau)**2 fxa = fxa + maskU(i,j+1,k)*u(i,j+1,k,tau)**2 + maskU(i-1,j+1,k)*u(i-1,j+1,k,tau)**2 - fxa = sqrt(v(i,j,k,tau)**2+ 0.25*fxa ) + fxa = sqrt(v(i,j,k,tau)**2+ 0.25d0*fxa ) aloc(i,j)= maskV(i,j,k)*r_quad_bot*v(i,j,k,tau)*fxa/dzt(k) dv_mix(i,j,k)=dv_mix(i,j,k) - aloc(i,j) endif @@ -477,7 +477,7 @@ subroutine quadratic_bottom_friction enddo if (enable_conserve_energy) then - diss=0.0 + diss=0.0d0 do j=js_pe-1,je_pe do i=is_pe,ie_pe k=max(kbot(i,j+1),kbot(i,j)) @@ -499,10 +499,10 @@ end subroutine quadratic_bottom_friction subroutine harmonic_friction !======================================================================= -! horizontal harmonic friction +! horizontal harmonic friction ! dissipation is calculated and added to K_diss_h !======================================================================= - use main_module + use main_module implicit none integer :: i,j,k integer :: is,ie,js,je @@ -523,7 +523,7 @@ subroutine harmonic_friction do j=js,je-1 fxa = cosu(j)**hor_friction_cosPower flux_north(:,j,:)=fxa*A_h*(u(:,j+1,:,tau)-u(:,j,:,tau))/dyu(j)*maskU(:,j+1,:)*maskU(:,j,:)*cosu(j) - enddo + enddo else do j=js,je do i=is,ie-1 @@ -532,13 +532,13 @@ subroutine harmonic_friction enddo do j=js,je-1 flux_north(:,j,:)=A_h*(u(:,j+1,:,tau)-u(:,j,:,tau))/dyu(j)*maskU(:,j+1,:)*maskU(:,j,:)*cosu(j) - enddo + enddo endif - flux_east(ie,:,:)=0. - flux_north(:,je,:)=0. + flux_east(ie,:,:)=0.d0 + flux_north(:,je,:)=0.d0 !--------------------------------------------------------------------------------- - ! update tendency + ! update tendency !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe,ie_pe @@ -554,10 +554,10 @@ subroutine harmonic_friction do k=1,nz do j=js_pe,je_pe do i=is_pe-1,ie_pe - diss(i,j,k) =0.5*((u(i+1,j,k,tau)-u(i,j,k,tau))*flux_east(i,j,k) & + diss(i,j,k) =0.5d0*((u(i+1,j,k,tau)-u(i,j,k,tau))*flux_east(i,j,k) & +(u(i,j,k,tau)-u(i-1,j,k,tau))*flux_east(i-1,j,k))/(cost(j)*dxu(i)) & - +0.5*((u(i,j+1,k,tau)-u(i,j,k,tau))*flux_north(i,j,k)+ & - (u(i,j,k,tau)-u(i,j-1,k,tau))*flux_north(i,j-1,k))/(cost(j)*dyt(j)) + +0.5d0*((u(i,j+1,k,tau)-u(i,j,k,tau))*flux_north(i,j,k)+ & + (u(i,j,k,tau)-u(i,j-1,k,tau))*flux_north(i,j-1,k))/(cost(j)*dyt(j)) enddo enddo enddo @@ -589,11 +589,11 @@ subroutine harmonic_friction flux_north(:,j,:)=A_h*(v(:,j+1,:,tau)-v(:,j,:,tau) )/dyt(j+1)*cost(j+1)*maskV(:,j,:)*maskV(:,j+1,:) enddo endif - flux_east(ie,:,:)=0. - flux_north(:,je,:)=0. + flux_east(ie,:,:)=0.d0 + flux_north(:,je,:)=0.d0 !--------------------------------------------------------------------------------- - ! update tendency + ! update tendency !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe,ie_pe @@ -609,10 +609,10 @@ subroutine harmonic_friction do k=1,nz do j=js_pe-1,je_pe do i=is_pe,ie_pe - diss(i,j,k) =0.5*((v(i+1,j,k,tau)-v(i,j,k,tau))*flux_east(i,j,k)+ & + diss(i,j,k) =0.5d0*((v(i+1,j,k,tau)-v(i,j,k,tau))*flux_east(i,j,k)+ & (v(i,j,k,tau)-v(i-1,j,k,tau))*flux_east(i-1,j,k))/(cosu(j)*dxt(i)) & - + 0.5*((v(i,j+1,k,tau)-v(i,j,k,tau))*flux_north(i,j,k)+ & - (v(i,j,k,tau)-v(i,j-1,k,tau))*flux_north(i,j-1,k))/(cosu(j)*dyu(j)) + + 0.5d0*((v(i,j+1,k,tau)-v(i,j,k,tau))*flux_north(i,j,k)+ & + (v(i,j,k,tau)-v(i,j-1,k,tau))*flux_north(i,j-1,k))/(cosu(j)*dyu(j)) enddo enddo enddo @@ -634,11 +634,11 @@ subroutine harmonic_friction do j=js,je-1 flux_north(:,j,:)=A_h*(w(:,j+1,:,tau)-w(:,j,:,tau))/dyu(j)*maskW(:,j+1,:)*maskW(:,j,:)*cosu(j) enddo - flux_east(ie,:,:)=0. - flux_north(:,je,:)=0. + flux_east(ie,:,:)=0.d0 + flux_north(:,je,:)=0.d0 !--------------------------------------------------------------------------------- - ! update tendency + ! update tendency !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe,ie_pe @@ -661,10 +661,10 @@ end subroutine harmonic_friction subroutine biharmonic_friction !======================================================================= -! horizontal biharmonic friction +! horizontal biharmonic friction ! dissipation is calculated and added to K_diss_h !======================================================================= - use main_module + use main_module implicit none integer :: i,j,is,ie,js,je real*8 :: del2(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz),fxa @@ -685,14 +685,14 @@ subroutine biharmonic_friction enddo do j=js,je-1 flux_north(:,j,:)=fxa*(u(:,j+1,:,tau)-u(:,j,:,tau))/dyu(j)*maskU(:,j+1,:)*maskU(:,j,:)*cosu(j) - enddo - flux_east(ie,:,:)=0. - flux_north(:,je,:)=0. + enddo + flux_east(ie,:,:)=0.d0 + flux_north(:,je,:)=0.d0 do j=js+1,je do i=is+1,ie del2(i,j,:)= (flux_east(i,j,:) - flux_east(i-1,j,:))/(cost(j)*dxu(i)) & - +(flux_north(i,j,:) - flux_north(i,j-1,:))/(cost(j)*dyt(j)) + +(flux_north(i,j,:) - flux_north(i,j-1,:))/(cost(j)*dyt(j)) enddo enddo @@ -703,12 +703,12 @@ subroutine biharmonic_friction enddo do j=js,je-1 flux_north(:,j,:)=fxa*(del2(:,j+1,:)-del2(:,j,:))/dyu(j)*maskU(:,j+1,:)*maskU(:,j,:)*cosu(j) - enddo - flux_east(ie,:,:)=0. - flux_north(:,je,:)=0. + enddo + flux_east(ie,:,:)=0.d0 + flux_north(:,je,:)=0.d0 !--------------------------------------------------------------------------------- - ! update tendency + ! update tendency !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe,ie_pe @@ -721,16 +721,16 @@ subroutine biharmonic_friction !--------------------------------------------------------------------------------- ! diagnose dissipation by lateral friction !--------------------------------------------------------------------------------- - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_east) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_east) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_east) - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_north) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_north) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_north) do j=js_pe,je_pe do i=is_pe-1,ie_pe - diss(i,j,:) =-0.5*((u(i+1,j,:,tau)-u(i,j,:,tau))*flux_east(i,j,:) & + diss(i,j,:) =-0.5d0*((u(i+1,j,:,tau)-u(i,j,:,tau))*flux_east(i,j,:) & +(u(i,j,:,tau)-u(i-1,j,:,tau))*flux_east(i-1,j,:))/(cost(j)*dxu(i)) & - -0.5*((u(i,j+1,:,tau)-u(i,j,:,tau))*flux_north(i,j,:)+ & - (u(i,j,:,tau)-u(i,j-1,:,tau))*flux_north(i,j-1,:))/(cost(j)*dyt(j)) + -0.5d0*((u(i,j+1,:,tau)-u(i,j,:,tau))*flux_north(i,j,:)+ & + (u(i,j,:,tau)-u(i,j-1,:,tau))*flux_north(i,j-1,:))/(cost(j)*dyt(j)) enddo enddo K_diss_h=0 @@ -748,13 +748,13 @@ subroutine biharmonic_friction do j=js,je-1 flux_north(:,j,:)=fxa*(v(:,j+1,:,tau)-v(:,j,:,tau) )/dyt(j+1)*cost(j+1)*maskV(:,j,:)*maskV(:,j+1,:) enddo - flux_east(ie,:,:)=0. - flux_north(:,je,:)=0. + flux_east(ie,:,:)=0.d0 + flux_north(:,je,:)=0.d0 do j=js+1,je do i=is+1,ie del2(i,j,:)= (flux_east(i,j,:) - flux_east(i-1,j,:))/(cosu(j)*dxt(i)) & - +(flux_north(i,j,:) - flux_north(i,j-1,:))/(dyu(j)*cosu(j)) + +(flux_north(i,j,:) - flux_north(i,j-1,:))/(dyu(j)*cosu(j)) enddo enddo @@ -766,11 +766,11 @@ subroutine biharmonic_friction do j=js,je-1 flux_north(:,j,:)=fxa*(del2(:,j+1,:)-del2(:,j,:) )/dyt(j+1)*cost(j+1)*maskV(:,j,:)*maskV(:,j+1,:) enddo - flux_east(ie,:,:)=0. - flux_north(:,je,:)=0. + flux_east(ie,:,:)=0.d0 + flux_north(:,je,:)=0.d0 !--------------------------------------------------------------------------------- - ! update tendency + ! update tendency !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe,ie_pe @@ -783,16 +783,16 @@ subroutine biharmonic_friction !--------------------------------------------------------------------------------- ! diagnose dissipation by lateral friction !--------------------------------------------------------------------------------- - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_east) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_east) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_east) - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_north) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_north) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,flux_north) do j=js_pe-1,je_pe do i=is_pe,ie_pe - diss(i,j,:) =-0.5*((v(i+1,j,:,tau)-v(i,j,:,tau))*flux_east(i,j,:)+ & + diss(i,j,:) =-0.5d0*((v(i+1,j,:,tau)-v(i,j,:,tau))*flux_east(i,j,:)+ & (v(i,j,:,tau)-v(i-1,j,:,tau))*flux_east(i-1,j,:))/(cosu(j)*dxt(i)) & - - 0.5*((v(i,j+1,:,tau)-v(i,j,:,tau))*flux_north(i,j,:)+ & - (v(i,j,:,tau)-v(i,j-1,:,tau))*flux_north(i,j-1,:))/(cosu(j)*dyu(j)) + - 0.5d0*((v(i,j+1,:,tau)-v(i,j,:,tau))*flux_north(i,j,:)+ & + (v(i,j,:,tau)-v(i,j-1,:,tau))*flux_north(i,j-1,:))/(cosu(j)*dyu(j)) enddo enddo call calc_diss(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss,K_diss_h,'V') @@ -811,7 +811,7 @@ subroutine momentum_sources ! other momentum sources ! dissipation is calculated and added to K_diss_bot !======================================================================= - use main_module + use main_module implicit none integer :: k real*8 :: diss(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) @@ -836,6 +836,3 @@ subroutine momentum_sources call calc_diss(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss,K_diss_bot,'V') endif end subroutine momentum_sources - - - diff --git a/for_src/main/main.f90 b/for_src/main/main.f90 index d071705..c4185f8 100644 --- a/for_src/main/main.f90 +++ b/for_src/main/main.f90 @@ -5,14 +5,14 @@ program main !======================================================================= -! Top level driver +! Top level driver !======================================================================= - use main_module - use eke_module - use tke_module - use idemix_module - use diagnostics_module - use timing_module + use main_module + use eke_module + use tke_module + use idemix_module + use diagnostics_module + use timing_module implicit none integer :: ierr,otaum1,iargc,n character (len=80) :: arg @@ -58,7 +58,7 @@ program main !--------------------------------------------------------------------------------- ! Begin main model loop !--------------------------------------------------------------------------------- - do while (itt < enditt) + do while (itt < enditt) call tic('main loop') call set_forcing @@ -74,7 +74,7 @@ program main call tic('temp') call thermodynamics call toc('temp') - + if (enable_eke .or. enable_tke .or. enable_idemix) call calculate_velocity_on_wgrid call tic('eke') @@ -96,41 +96,41 @@ program main ! Main boundary exchange ! for density, temp and salt this is done in integrate_tempsalt.f90 !--------------------------------------------------------------------------------- - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,u(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,u(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,u(:,:,:,taup1)) - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,v(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,v(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,v(:,:,:,taup1)) if (enable_tke) then - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,tke(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,tke(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,tke(:,:,:,taup1)) endif if (enable_eke) then - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,eke(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,eke(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,eke(:,:,:,taup1)) endif if (enable_idemix) then - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,E_iw(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,E_iw(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,E_iw(:,:,:,taup1)) endif if (enable_idemix_M2) then - call border_exchg_xyp(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,np,E_M2(:,:,:,taup1)) + call border_exchg_xyp(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,np,E_M2(:,:,:,taup1)) call setcyclic_xyp (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,np,E_M2(:,:,:,taup1)) endif if (enable_idemix_niw) then - call border_exchg_xyp(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,np,E_niw(:,:,:,taup1)) + call border_exchg_xyp(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,np,E_niw(:,:,:,taup1)) call setcyclic_xyp (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,np,E_niw(:,:,:,taup1)) endif - + ! diagnose vertical velocity at taup1 if (enable_hydrostatic) call vertical_velocity call toc('main loop') - + call tic('diag') call diagnose call toc('diag') - - ! shift time + + ! shift time otaum1=taum1; taum1= tau; tau = taup1; taup1= otaum1; itt=itt+1 !--------------------------------------------------------------------------------- ! End main model loop @@ -155,7 +155,7 @@ program main do n = 0,n_pes call fortran_barrier if (my_pe == n) then - print'(/,a,i4)','Timing summary for PE #',my_pe + print'(/,a,i4)','Timing summary for PE #',my_pe print'(a,f12.1,a)',' costs for measuring = ',timing_secs('tictoc'),' s' print'(a,f12.1,a)',' setup time summary = ',timing_secs('setup'),' s' print'(a,f12.1,a)',' main loop time summary = ',timing_secs('main loop') ,' s' @@ -179,12 +179,12 @@ end program main subroutine setup !======================================================================= -! setup everything +! setup everything !======================================================================= - use main_module - use eke_module - use tke_module - use idemix_module + use main_module + use eke_module + use tke_module + use idemix_module implicit none if (my_pe==0) print'(/a/)','setting up everything' @@ -220,7 +220,7 @@ subroutine setup call calc_spectral_topo !-------------------------------------------------------------- -! initial condition and forcing +! initial condition and forcing !-------------------------------------------------------------- call set_initial_conditions call calc_initial_conditions @@ -250,4 +250,3 @@ subroutine setup endif end subroutine setup - diff --git a/for_src/main/main_module.f90 b/for_src/main/main_module.f90 index 481e582..5877acb 100644 --- a/for_src/main/main_module.f90 +++ b/for_src/main/main_module.f90 @@ -1,6 +1,6 @@ -module main_module +module main_module !======================================================================= ! main module containing most important arrays and parameter ! others can be found in specific modules @@ -9,14 +9,14 @@ module main_module !--------------------------------------------------------------------------------- ! constants and parameter !--------------------------------------------------------------------------------- - real*8, parameter :: version = 2.10 - real*8, parameter :: pi = 3.14159265358979323846264338327950588 - real*8, parameter :: radius = 6370.0e3 ! Earth radius in m - real*8, parameter :: degtom = radius/180.0*pi ! conversion degrees latitude to meters - real*8, parameter :: mtodeg = 1/degtom ! revers conversion - real*8, parameter :: omega = pi/43082.0 ! earth rotation frequency in 1/s - real*8, parameter :: rho_0 = 1024.0 ! Boussinesq reference density in kg/m^3 - real*8, parameter :: grav = 9.81 ! gravitational constant in m/s^2 + real*8, parameter :: version = 2.10d0 + real*8, parameter :: pi = 3.14159265358979323846264338327950588d0 + real*8, parameter :: radius = 6370.0d3 ! Earth radius in m + real*8, parameter :: degtom = radius/180.0d0*pi ! conversion degrees latitude to meters + real*8, parameter :: mtodeg = 1/degtom ! revers conversion + real*8, parameter :: omega = pi/43082.0d0 ! earth rotation frequency in 1/s + real*8, parameter :: rho_0 = 1024.0d0 ! Boussinesq reference density in kg/m^3 + real*8, parameter :: grav = 9.81d0 ! gravitational constant in m/s^2 !--------------------------------------------------------------------------------- ! Parallel domain setup !--------------------------------------------------------------------------------- @@ -26,7 +26,7 @@ module main_module integer :: n_pes_j ! total number of processors in y direction integer :: my_blk_i ! index of this processor in x direction from 1 to n_pes_i integer :: my_blk_j ! index of this processor in y direction from 1 to n_pes_j - integer :: i_blk ! grid points of domain decompostion in x direction + integer :: i_blk ! grid points of domain decompostion in x direction integer :: j_blk ! grid points of domain decompostion in y direction integer :: is_pe ! start index of grid points in x direction of this processor integer :: ie_pe ! end index of grid points in x direction of this processor @@ -40,7 +40,7 @@ module main_module integer :: nx ! grid points in zonal (x,i) direction integer :: ny ! grid points in meridional (y,j) direction integer :: nz ! grid points in vertical (z,k) direction - integer :: taum1 = 1 ! pointer to last time step + integer :: taum1 = 1 ! pointer to last time step integer :: tau = 2 ! pointer to current time step integer :: taup1 = 3 ! pointer to next time step real*8 :: dt_mom = 0 ! time step in seconds for momentum @@ -48,12 +48,12 @@ module main_module real*8 :: dt_tke ! should be time step for momentum (set in tke.f90) integer :: itt ! time step number integer :: enditt ! last time step of simulation - real*8 :: runlen=0. ! length of simulation in seconds - real*8 :: AB_eps = 0.1 ! deviation from Adam-Bashforth weighting + real*8 :: runlen=0.d0 ! length of simulation in seconds + real*8 :: AB_eps = 0.1d0 ! deviation from Adam-Bashforth weighting !--------------------------------------------------------------------------------- ! logical switches for general model setup !--------------------------------------------------------------------------------- - logical :: coord_degree = .false. ! either spherical (true) or cartesian (false) coordinates + logical :: coord_degree = .false. ! either spherical (true) or cartesian (false) coordinates logical :: enable_cyclic_x = .false. ! enable cyclic boundary conditions integer :: eq_of_state_type = 1 ! equation of state: 1: linear, 3: nonlinear with comp., 5: TEOS logical :: enable_implicit_vert_friction = .false. ! enable implicit vertical friction @@ -98,7 +98,7 @@ module main_module real*8, allocatable, dimension(:,:) :: coriolis_h ! horizontal coriolis frequency at T grid point in 1/s real*8, allocatable, dimension(:) :: cost ! metric factor for spherical coordinates on T grid real*8, allocatable, dimension(:) :: cosu ! metric factor for spherical coordinates on U grid - real*8, allocatable, dimension(:) :: tantr ! metric factor for spherical coordinates + real*8, allocatable, dimension(:) :: tantr ! metric factor for spherical coordinates real*8, allocatable, dimension(:,:) :: ht ! total depth in m real*8, allocatable, dimension(:,:) :: hu,hur ! total depth in m at u-grid real*8, allocatable, dimension(:,:) :: hv,hvr ! total depth in m at v-grid @@ -109,7 +109,7 @@ module main_module real*8, allocatable, dimension(:,:,:,:) :: temp,dtemp ! conservative temperature in deg C and its tendency real*8, allocatable, dimension(:,:,:,:) :: salt,dsalt ! salinity in g/Kg and its tendency real*8, allocatable, dimension(:,:,:,:) :: rho ! density in kg/m^3 - real*8, allocatable, dimension(:,:,:,:) :: Hd ! dynamic enthalpy + real*8, allocatable, dimension(:,:,:,:) :: Hd ! dynamic enthalpy real*8, allocatable, dimension(:,:,:,:) :: int_drhodT,int_drhodS ! partial derivatives of dyn. enthalpy real*8, allocatable, dimension(:,:,:,:) :: Nsqr ! Square of stability frequency in 1/s^2 real*8, allocatable, dimension(:,:,:,:) :: dHd ! change of dynamic enthalpy due to advection @@ -149,7 +149,7 @@ module main_module real*8, allocatable, dimension(:,:,:) :: u_wgrid,v_wgrid,w_wgrid ! velocity on W grid real*8, allocatable, dimension(:,:,:) :: flux_east,flux_north,flux_top ! multi purpose fluxes !--------------------------------------------------------------------------------- -! variables related to dissipation +! variables related to dissipation !--------------------------------------------------------------------------------- real*8, allocatable, dimension(:,:,:) :: K_diss_v ! kinetic energy dissipation by vertical, rayleigh and bottom friction real*8, allocatable, dimension(:,:,:) :: K_diss_h ! kinetic energy dissipation by horizontal friction @@ -157,10 +157,10 @@ module main_module real*8, allocatable, dimension(:,:,:) :: K_diss_bot ! mean energy dissipation by bottom and rayleigh friction real*8, allocatable, dimension(:,:,:) :: P_diss_v ! potential energy dissipation by vertical diffusion real*8, allocatable, dimension(:,:,:) :: P_diss_nonlin ! potential energy dissipation by nonlinear equation of state - real*8, allocatable, dimension(:,:,:) :: P_diss_adv ! potential energy dissipation by + real*8, allocatable, dimension(:,:,:) :: P_diss_adv ! potential energy dissipation by real*8, allocatable, dimension(:,:,:) :: P_diss_comp ! potential energy dissipation by compress. real*8, allocatable, dimension(:,:,:) :: P_diss_hmix ! potential energy dissipation by horizontal mixing - real*8, allocatable, dimension(:,:,:) :: P_diss_iso ! potential energy dissipation by isopycnal mixing + real*8, allocatable, dimension(:,:,:) :: P_diss_iso ! potential energy dissipation by isopycnal mixing real*8, allocatable, dimension(:,:,:) :: P_diss_skew ! potential energy dissipation by GM (w/o TRM) real*8, allocatable, dimension(:,:,:) :: P_diss_sources ! potential energy dissipation by restoring zones, etc !--------------------------------------------------------------------------------- @@ -170,24 +170,24 @@ module main_module logical :: enable_streamfunction= .false. ! solve for streamfct instead of surface pressure logical :: enable_congrad_verbose = .false. ! print some info integer :: congr_itts ! number of iterations of poisson solver - real*8 :: congr_epsilon=1e-12 ! convergence criteria for poisson solver + real*8 :: congr_epsilon=1d-12 ! convergence criteria for poisson solver integer :: congr_max_iterations = 1000 ! max. number of iterations integer :: nisle ! number of islands integer, allocatable :: boundary(:,:,:),nr_boundary(:),line_dir(:,:,:) ! positions and direction for island integrals !--------------------------------------------------------------------------------- ! mixing parameter !--------------------------------------------------------------------------------- - real*8 :: A_h=0.0 ! lateral viscosity in m^2/s - real*8 :: K_h=0.0 ! lateral diffusivity in m^2/s - real*8 :: r_ray=0.0 ! Rayleigh damping coefficient in 1/s - real*8 :: r_bot=0.0 ! bottom friction coefficient in 1/s - real*8 :: r_quad_bot=0.0 ! qudratic bottom friction coefficient + real*8 :: A_h=0.0d0 ! lateral viscosity in m^2/s + real*8 :: K_h=0.0d0 ! lateral diffusivity in m^2/s + real*8 :: r_ray=0.0d0 ! Rayleigh damping coefficient in 1/s + real*8 :: r_bot=0.0d0 ! bottom friction coefficient in 1/s + real*8 :: r_quad_bot=0.0d0 ! qudratic bottom friction coefficient real*8, allocatable :: r_bot_var_u(:,:) ! bottom friction coefficient in 1/s, on u points real*8, allocatable :: r_bot_var_v(:,:) ! bottom friction coefficient in 1/s, on v points integer :: hor_friction_cosPower = 3 - real*8 :: A_hbi=0.0 ! lateral bihamronic viscosity in m^4/s - real*8 :: K_hbi=0.0 ! lateral bihamronic diffusivity in m^4/s - real*8 :: kappaH_0 = 0.0, kappaM_0 = 0.0 ! fixed values for vertical viscosity/diffusivity which are set for no TKE model + real*8 :: A_hbi=0.0d0 ! lateral bihamronic viscosity in m^4/s + real*8 :: K_hbi=0.0d0 ! lateral bihamronic diffusivity in m^4/s + real*8 :: kappaH_0 = 0.0d0, kappaM_0 = 0.0d0 ! fixed values for vertical viscosity/diffusivity which are set for no TKE model real*8, allocatable :: kappaM(:,:,:) ! vertical viscosity in m^2/s real*8, allocatable :: kappaH(:,:,:) ! vertical diffusivity in m^2/s !--------------------------------------------------------------------------------- @@ -200,16 +200,16 @@ module main_module real*8,allocatable :: dw_adv(:,:,:) real*8,allocatable :: dw_mix(:,:,:) integer :: congr_itts_non_hydro ! number of iterations of poisson solver - real*8 :: congr_epsilon_non_hydro=1e-12 ! convergence criteria for poisson solver + real*8 :: congr_epsilon_non_hydro=1d-12 ! convergence criteria for poisson solver integer :: congr_max_itts_non_hydro = 1000 ! max. number of iterations -end module main_module +end module main_module subroutine allocate_main_module !======================================================================= ! allocate all arrays within main module !======================================================================= - use main_module + use main_module implicit none allocate( xt(is_pe-onx:ie_pe+onx), xu(is_pe-onx:ie_pe+onx)) ; xt=0;xu=0 @@ -218,8 +218,8 @@ subroutine allocate_main_module allocate( dyt(js_pe-onx:je_pe+onx), dyu(js_pe-onx:je_pe+onx)) ; dyt=0;dyu=0 allocate( zt(nz), dzt(nz), zw(nz), dzw(nz) ); zt=0; zw=0; dzt=0; dzw=0 - allocate( cost(js_pe-onx:je_pe+onx), cosu(js_pe-onx:je_pe+onx)); cost=1.0; cosu=1.0; - allocate( tantr(js_pe-onx:je_pe+onx)); tantr = 0.0 + allocate( cost(js_pe-onx:je_pe+onx), cosu(js_pe-onx:je_pe+onx)); cost=1.0d0; cosu=1.0d0; + allocate( tantr(js_pe-onx:je_pe+onx)); tantr = 0.0d0 allocate( coriolis_t(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx) ); coriolis_t=0 allocate( coriolis_h(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx) ); coriolis_h=0 @@ -239,7 +239,7 @@ subroutine allocate_main_module allocate( maskV(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ) allocate( maskW(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ) allocate( maskZ(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ) - maskW=0.; maskT=0.; maskU=0.; maskV=0.; maskZ =0.; + maskW=0.d0; maskT=0.d0; maskU=0.d0; maskV=0.d0; maskZ =0.d0; allocate( rho(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz,3) ); rho = 0 allocate(Nsqr(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz,3) ); Nsqr = 0 @@ -321,14 +321,9 @@ subroutine allocate_main_module allocate( dw_mix(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); dw_mix = 0 endif - allocate( u_wgrid(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); u_wgrid = 0.0 - allocate( v_wgrid(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); v_wgrid = 0.0 - allocate( w_wgrid(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); w_wgrid = 0.0 + allocate( u_wgrid(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); u_wgrid = 0.0d0 + allocate( v_wgrid(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); v_wgrid = 0.0d0 + allocate( w_wgrid(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); w_wgrid = 0.0d0 end subroutine allocate_main_module - - - - - diff --git a/for_src/main/momentum.f90 b/for_src/main/momentum.f90 index 424aa70..37370cd 100644 --- a/for_src/main/momentum.f90 +++ b/for_src/main/momentum.f90 @@ -5,9 +5,9 @@ subroutine momentum !======================================================================= ! solve for momentum for taup1 !======================================================================= - use main_module - use isoneutral_module - use timing_module + use main_module + use isoneutral_module + use timing_module implicit none integer :: i,j,k @@ -17,9 +17,9 @@ subroutine momentum do j=js_pe,je_pe do i=is_pe,ie_pe du_cor(i,j,:)= maskU(i,j,:)*( coriolis_t(i ,j)*(v(i ,j,:,tau)+v(i ,j-1,:,tau))*dxt(i )/dxu(i) & - +coriolis_t(i+1,j)*(v(i+1,j,:,tau)+v(i+1,j-1,:,tau))*dxt(i+1)/dxu(i) )*0.25 + +coriolis_t(i+1,j)*(v(i+1,j,:,tau)+v(i+1,j-1,:,tau))*dxt(i+1)/dxu(i) )*0.25d0 dv_cor(i,j,:)=-maskV(i,j,:)*(coriolis_t(i,j )*(u(i-1,j ,:,tau)+u(i,j ,:,tau))*dyt(j )*cost(j )/( dyu(j)*cosu(j) ) & - +coriolis_t(i,j+1)*(u(i-1,j+1,:,tau)+u(i,j+1,:,tau))*dyt(j+1)*cost(j+1)/( dyu(j)*cosu(j) ) )*0.25 + +coriolis_t(i,j+1)*(u(i-1,j+1,:,tau)+u(i,j+1,:,tau))*dyt(j+1)*cost(j+1)/( dyu(j)*cosu(j) ) )*0.25d0 enddo enddo @@ -29,10 +29,10 @@ subroutine momentum if (coord_degree) then do j=js_pe,je_pe do i=is_pe,ie_pe - du_cor(i,j,:) = du_cor(i,j,:) + maskU(i,j,:)*0.125*tantr(j)*( & + du_cor(i,j,:) = du_cor(i,j,:) + maskU(i,j,:)*0.125d0*tantr(j)*( & (u(i ,j,:,tau)+u(i-1,j,:,tau))*(v(i ,j,:,tau)+v(i ,j-1,:,tau))*dxt(i )/dxu(i) & + (u(i+1,j,:,tau)+u(i ,j,:,tau))*(v(i+1,j,:,tau)+v(i+1,j-1,:,tau))*dxt(i+1)/dxu(i) ) - dv_cor(i,j,:) = dv_cor(i,j,:) - maskV(i,j,:)*0.125*( & + dv_cor(i,j,:) = dv_cor(i,j,:) - maskV(i,j,:)*0.125d0*( & tantr(j )*(u(i,j ,:,tau)+u(i-1,j ,:,tau))**2*dyt(j )*cost(j )/( dyu(j)*cosu(j) ) & + tantr(j+1)*(u(i,j+1,:,tau)+u(i-1,j+1,:,tau))**2*dyt(j+1)*cost(j+1)/( dyu(j)*cosu(j) ) ) enddo @@ -45,19 +45,19 @@ subroutine momentum if (.not. enable_hydrostatic) then do k=2,nz do i=is_pe,ie_pe - du_cor(i,:,k) = du_cor(i,:,k) - maskU(i,:,k)*0.25*(coriolis_h(i ,:)*area_t(i ,:)*(w(i ,:,k,tau)+w(i ,:,k-1,tau)) & + du_cor(i,:,k) = du_cor(i,:,k) - maskU(i,:,k)*0.25d0*(coriolis_h(i ,:)*area_t(i ,:)*(w(i ,:,k,tau)+w(i ,:,k-1,tau)) & +coriolis_h(i+1,:)*area_t(i+1,:)*(w(i+1,:,k,tau)+w(i+1,:,k-1,tau)) ) & /area_u(i,:) enddo enddo k=1; do i=is_pe,ie_pe - du_cor(i,:,k) = du_cor(i,:,k) - maskU(i,:,k)*0.25*(coriolis_h(i ,:)*area_t(i ,:)*(w(i ,:,k,tau)) & + du_cor(i,:,k) = du_cor(i,:,k) - maskU(i,:,k)*0.25d0*(coriolis_h(i ,:)*area_t(i ,:)*(w(i ,:,k,tau)) & +coriolis_h(i+1,:)*area_t(i+1,:)*(w(i+1,:,k,tau)) )/area_u(i,:) enddo do k=1,nz-1 do i=is_pe,ie_pe - dw_cor(i,:,k) = maskW(i,:,k)*0.25*(coriolis_h(i,:)*dzt(k )*(u(i,:,k ,tau)+u(i-1,:,k ,tau)) & + dw_cor(i,:,k) = maskW(i,:,k)*0.25d0*(coriolis_h(i,:)*dzt(k )*(u(i,:,k ,tau)+u(i-1,:,k ,tau)) & +coriolis_h(i,:)*dzt(k+1)*(u(i,:,k+1,tau)+u(i-1,:,k+1,tau)) )/dzw(k) enddo enddo @@ -140,7 +140,7 @@ subroutine momentum call solve_streamfunction else call solve_pressure - if (itt==0) then + if (itt==0) then psi(:,:,tau)=psi(:,:,taup1) psi(:,:,taum1)=psi(:,:,taup1) endif @@ -153,14 +153,14 @@ end subroutine momentum - + subroutine vertical_velocity !======================================================================= -! vertical velocity from continuity : -! \int_0^z w_z dz =w(z)-w(0) = - \int dz (u_x +v_y) +! vertical velocity from continuity : +! \int_0^z w_z dz =w(z)-w(0) = - \int dz (u_x +v_y) ! w(z)=-int dz u_x + v_y !======================================================================= - use main_module + use main_module implicit none integer :: i,j,k ! integrate from bottom to surface to see error in w @@ -190,7 +190,7 @@ subroutine momentum_advection !======================================================================= ! Advection of momentum with second order which is energy conserving !======================================================================= - use main_module + use main_module implicit none integer :: i,j,k real*8 :: utr(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) @@ -205,18 +205,18 @@ subroutine momentum_advection ! uTrans(i,j) = u(i,j)*dyG(i,j)*drF(k) ! vTrans(i,j) = v(i,j)*dxG(i,j)*drF(k) -! fZon(i,j) = 0.25*( uTrans(i,j) + uTrans(i+1,j) ) *( u(i,j) + u(i+1,j) ) -! fMer(i,j) = 0.25*( vTrans(i,j) + vTrans(i-1,j) ) *( u(i,j) + u(i,j-1) ) +! fZon(i,j) = 0.25d0*( uTrans(i,j) + uTrans(i+1,j) ) *( u(i,j) + u(i+1,j) ) +! fMer(i,j) = 0.25d0*( vTrans(i,j) + vTrans(i-1,j) ) *( u(i,j) + u(i,j-1) ) ! gU(i,j,k,bi,bj) = - ! & *( ( fZon(i,j ) - fZon(i-1,j) ) ! & +( fMer(i,j+1) - fMer(i, j) ) ! & +( fVerUkp(i,j) - fVerUkm(i,j) ) -! & ) /drF(k) / rAw(i,j) +! & ) /drF(k) / rAw(i,j) -! fZon(i,j) = 0.25*( uTrans(i,j) + uTrans(i,j-1) ) *(v(i,j) + v(i-1,j) ) -! fMer(i,j) = 0.25*( vTrans(i,j) + vTrans(i,j+1) ) *(v(i,j) + v(i,j+1) ) +! fZon(i,j) = 0.25d0*( uTrans(i,j) + uTrans(i,j-1) ) *(v(i,j) + v(i-1,j) ) +! fMer(i,j) = 0.25d0*( vTrans(i,j) + vTrans(i,j+1) ) *(v(i,j) + v(i,j+1) ) ! gV(i,j,k,bi,bj) = -recip_drF(k)*recip_rAs(i,j,bi,bj) ! & *( ( fZon(i+1,j) - fZon(i,j ) ) @@ -238,22 +238,22 @@ subroutine momentum_advection !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe-1,ie_pe - flux_east(i,j,:) = 0.25*(u(i,j,:,tau)+u(i+1,j,:,tau))*(utr(i+1,j,:)+utr(i,j,:)) + flux_east(i,j,:) = 0.25d0*(u(i,j,:,tau)+u(i+1,j,:,tau))*(utr(i+1,j,:)+utr(i,j,:)) enddo enddo do j=js_pe-1,je_pe do i=is_pe,ie_pe - flux_north(i,j,:) = 0.25*(u(i,j,:,tau)+u(i,j+1,:,tau))*(vtr(i+1,j,:)+vtr(i,j,:)) + flux_north(i,j,:) = 0.25d0*(u(i,j,:,tau)+u(i,j+1,:,tau))*(vtr(i+1,j,:)+vtr(i,j,:)) enddo enddo do k=1,nz-1 do j=js_pe,je_pe do i=is_pe,ie_pe - flux_top(i,j,k) = 0.25*(u(i,j,k+1,tau)+u(i,j,k,tau))*(wtr(i,j,k)+wtr(i+1,j,k)) + flux_top(i,j,k) = 0.25d0*(u(i,j,k+1,tau)+u(i,j,k,tau))*(wtr(i,j,k)+wtr(i+1,j,k)) enddo enddo enddo - flux_top(:,:,nz)=0.0 + flux_top(:,:,nz)=0.0d0 do j=js_pe,je_pe do i=is_pe,ie_pe du_adv(i,j,:) = - maskU(i,j,:)*( flux_east(i,j,:) -flux_east(i-1,j,:) & @@ -269,22 +269,22 @@ subroutine momentum_advection !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe-1,ie_pe - flux_east(i,j,:) = 0.25*(v(i,j,:,tau)+v(i+1,j,:,tau))*(utr(i,j+1,:)+utr(i,j,:)) + flux_east(i,j,:) = 0.25d0*(v(i,j,:,tau)+v(i+1,j,:,tau))*(utr(i,j+1,:)+utr(i,j,:)) enddo enddo do j=js_pe-1,je_pe do i=is_pe,ie_pe - flux_north(i,j,:) = 0.25*(v(i,j,:,tau)+v(i,j+1,:,tau))*(vtr(i,j+1,:)+vtr(i,j,:)) + flux_north(i,j,:) = 0.25d0*(v(i,j,:,tau)+v(i,j+1,:,tau))*(vtr(i,j+1,:)+vtr(i,j,:)) enddo enddo do k=1,nz-1 do j=js_pe,je_pe do i=is_pe,ie_pe - flux_top(i,j,k) = 0.25*(v(i,j,k+1,tau)+v(i,j,k,tau))*(wtr(i,j,k)+wtr(i,j+1,k)) + flux_top(i,j,k) = 0.25d0*(v(i,j,k+1,tau)+v(i,j,k,tau))*(wtr(i,j,k)+wtr(i,j+1,k)) enddo enddo enddo - flux_top(:,:,nz)=0.0 + flux_top(:,:,nz)=0.0d0 do j=js_pe,je_pe do i=is_pe,ie_pe dv_adv(i,j,:) = - maskV(i,j,:)*( flux_east(i,j,:) -flux_east(i-1,j,:) & @@ -304,26 +304,26 @@ subroutine momentum_advection do k=1,nz do j=js_pe,je_pe do i=is_pe-1,ie_pe - flux_east(i,j,k) = 0.5*(w(i,j,k,tau)+w(i+1,j,k,tau))*(u(i,j,k,tau)+u(i,j,min(nz,k+1),tau))*0.5*maskW(i+1,j,k)*maskW(i,j,k) + flux_east(i,j,k) = 0.5d0*(w(i,j,k,tau)+w(i+1,j,k,tau))*(u(i,j,k,tau)+u(i,j,min(nz,k+1),tau))*0.5d0*maskW(i+1,j,k)*maskW(i,j,k) enddo enddo enddo do k=1,nz do j=js_pe-1,je_pe do i=is_pe,ie_pe - flux_north(i,j,k) = 0.5*(w(i,j,k,tau)+w(i,j+1,k,tau))* & - (v(i,j,k,tau)+v(i,j,min(nz,k+1),tau))*0.5*maskW(i,j+1,k)*maskW(i,j,k)*cosu(j) + flux_north(i,j,k) = 0.5d0*(w(i,j,k,tau)+w(i,j+1,k,tau))* & + (v(i,j,k,tau)+v(i,j,min(nz,k+1),tau))*0.5d0*maskW(i,j+1,k)*maskW(i,j,k)*cosu(j) enddo enddo enddo do k=1,nz-1 do j=js_pe,je_pe do i=is_pe,ie_pe - flux_top(i,j,k) = 0.5*(w(i,j,k+1,tau)+w(i,j,k,tau))*(w(i,j,k,tau)+w(i,j,k+1,tau))*0.5*maskW(i,j,k+1)*maskW(i,j,k) + flux_top(i,j,k) = 0.5d0*(w(i,j,k+1,tau)+w(i,j,k,tau))*(w(i,j,k,tau)+w(i,j,k+1,tau))*0.5d0*maskW(i,j,k+1)*maskW(i,j,k) enddo enddo enddo - flux_top(:,:,nz)=0.0 + flux_top(:,:,nz)=0.0d0 do j=js_pe,je_pe do i=is_pe,ie_pe dw_adv(i,j,:)= maskW(i,j,:)* (-( flux_east(i,j,:)- flux_east(i-1,j,:))/(cost(j)*dxt(i)) & diff --git a/for_src/main/numerics.f90 b/for_src/main/numerics.f90 index 77d8751..2e784fe 100644 --- a/for_src/main/numerics.f90 +++ b/for_src/main/numerics.f90 @@ -6,22 +6,22 @@ subroutine u_centered_grid(dyt,dyu,yt,yu,n) !--------------------------------------------------------------------------------- ! setup u-centered grid based in Delta yt and the relations -! dyt_i = yu_i - yu_i-1 , yu_i = 0.5(yt_i+yt_(i+1)) , dyu_i = yt_(i+1)-yt_i +! dyt_i = yu_i - yu_i-1 , yu_i = 0.5d0(yt_i+yt_(i+1)) , dyu_i = yt_(i+1)-yt_i !--------------------------------------------------------------------------------- implicit none integer, intent(in) :: n real*8, intent(in) :: dyt(n) real*8, intent(out) :: yu(n),yt(n),dyu(n) - integer :: i + integer :: i yu(1)=0 - do i=2,n + do i=2,n yu(i)=yu(i-1)+dyt(i) enddo - yt(1)=yu(1)-dyt(1)*0.5 + yt(1)=yu(1)-dyt(1)*0.5d0 do i=2,n yt(i) = 2*yu(i-1) - yt(i-1) enddo - do i=1,n-1 + do i=1,n-1 dyu(i)= yt(i+1)-yt(i) enddo dyu(n)=2*dyt(n)- dyu(n-1) @@ -35,14 +35,14 @@ subroutine calc_grid !--------------------------------------------------------------------------------- ! setup grid based on dxt,dyt,dzt and x_origin, y_origin !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer :: i,j real*8 :: aloc(nx,ny) real*8, dimension(1-onx:nx+onx) :: dxt_gl,dxu_gl,xt_gl,xu_gl real*8, dimension(1-onx:ny+onx) :: dyt_gl,dyu_gl,yt_gl,yu_gl - aloc=0. + aloc=0.d0 !-------------------------------------------------------------- ! transfer from locally defined variables to global ones !-------------------------------------------------------------- @@ -53,11 +53,11 @@ subroutine calc_grid if (enable_cyclic_x) then do i=1,onx - dxt_gl(nx+i)=dxt_gl(i); dxt_gl(1-i)=dxt_gl(nx-i+1) + dxt_gl(nx+i)=dxt_gl(i); dxt_gl(1-i)=dxt_gl(nx-i+1) enddo else do i=1,onx - dxt_gl(nx+i)=dxt_gl(nx); dxt_gl(1-i)=dxt_gl(1) + dxt_gl(nx+i)=dxt_gl(nx); dxt_gl(1-i)=dxt_gl(1) enddo endif @@ -67,7 +67,7 @@ subroutine calc_grid dyt_gl(1:ny) = aloc(1,:) do i=1,onx - dyt_gl(ny+i)=dyt_gl(ny); dyt_gl(1-i)=dyt_gl(1) + dyt_gl(ny+i)=dyt_gl(ny); dyt_gl(1-i)=dyt_gl(1) enddo !-------------------------------------------------------------- ! grid in east/west direction @@ -78,9 +78,9 @@ subroutine calc_grid if (enable_cyclic_x) then do i=1,onx - xt_gl(nx+i)=xt_gl(i); xt_gl(1-i)=xt_gl(nx-i+1) - xu_gl(nx+i)=xt_gl(i); xu_gl(1-i)=xu_gl(nx-i+1) - dxu_gl(nx+i)=dxu_gl(i); dxu_gl(1-i)=dxu_gl(nx-i+1) + xt_gl(nx+i)=xt_gl(i); xt_gl(1-i)=xt_gl(nx-i+1) + xu_gl(nx+i)=xt_gl(i); xu_gl(1-i)=xu_gl(nx-i+1) + dxu_gl(nx+i)=dxu_gl(i); dxu_gl(1-i)=dxu_gl(nx-i+1) enddo endif @@ -116,20 +116,20 @@ subroutine calc_grid ! grid in vertical direction !-------------------------------------------------------------- call u_centered_grid(dzt,dzw,zt,zw,nz) - !dzw(nz)=dzt(nz) !*0.5 ! this is account for in the model directly - zt = zt - zw(nz); zw = zw - zw(nz) ! zero at zw(nz) + !dzw(nz)=dzt(nz) !*0.5d0 ! this is account for in the model directly + zt = zt - zw(nz); zw = zw - zw(nz) ! zero at zw(nz) !-------------------------------------------------------------- ! metric factors !-------------------------------------------------------------- if (coord_degree) then do j=js_pe-onx,je_pe+onx - cost(j) = cos( yt(j)/180.*pi ) - cosu(j) = cos( yu(j)/180.*pi ) - tantr(j) = tan( yt(j)/180.*pi ) /radius + cost(j) = cos( yt(j)/180.d0*pi ) + cosu(j) = cos( yu(j)/180.d0*pi ) + tantr(j) = tan( yt(j)/180.d0*pi ) /radius enddo else - cost=1.0;cosu=1.0;tantr=0.0 + cost=1.0d0;cosu=1.0d0;tantr=0.0d0 endif !-------------------------------------------------------------- @@ -150,13 +150,13 @@ subroutine calc_beta !-------------------------------------------------------------- ! calculate beta = df/dy !-------------------------------------------------------------- - use main_module + use main_module implicit none integer :: j do j=js_pe,je_pe - beta(:,j) = 0.5*( (coriolis_t(:,j+1)-coriolis_t(:,j))/dyu(j) + (coriolis_t(:,j)-coriolis_t(:,j-1))/dyu(j-1) ) + beta(:,j) = 0.5d0*( (coriolis_t(:,j+1)-coriolis_t(:,j))/dyu(j) + (coriolis_t(:,j)-coriolis_t(:,j-1))/dyu(j-1) ) enddo - call border_exchg_xy(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,beta) + call border_exchg_xy(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,beta) call setcyclic_xy (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,beta) end subroutine calc_beta @@ -165,7 +165,7 @@ subroutine calc_topo !-------------------------------------------------------------- ! calulate masks, total depth etc !-------------------------------------------------------------- - use main_module + use main_module implicit none integer :: i,j,k @@ -173,38 +173,38 @@ subroutine calc_topo ! close domain !-------------------------------------------------------------- if (my_blk_j == 1) kbot(:,1-onx:0)=0 - if (my_blk_j == n_pes_j) kbot(:,ny+1:ny+onx)=0 + if (my_blk_j == n_pes_j) kbot(:,ny+1:ny+onx)=0 if (.not. enable_cyclic_x) then if (my_blk_i == 1) kbot(1-onx:0,:)=0 - if (my_blk_i == n_pes_i) kbot(nx+1:nx+onx,:)=0 + if (my_blk_i == n_pes_i) kbot(nx+1:nx+onx,:)=0 endif - call border_exchg_xy_int(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,kbot) + call border_exchg_xy_int(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,kbot) call setcyclic_xy_int (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,kbot) - + !-------------------------------------------------------------- ! Land masks !-------------------------------------------------------------- - maskT = 0.0 + maskT = 0.0d0 do k=1,nz do j=js_pe-onx,je_pe+onx do i=is_pe-onx,ie_pe+onx - if ( kbot(i,j)/=0 .and. kbot(i,j) <= k ) maskT(i,j,k)=1.0 + if ( kbot(i,j)/=0 .and. kbot(i,j) <= k ) maskT(i,j,k)=1.0d0 enddo enddo enddo - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskT) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskT) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskT) maskU=maskT do i=is_pe-onx,ie_pe+onx-1 maskU(i,:,:)=min(maskT(i,:,:),maskT(i+1,:,:)) enddo - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskU) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskU) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskU) maskV=maskT do j=js_pe-onx,je_pe+onx-1 maskV(:,j,:)=min(maskT(:,j,:),maskT(:,j+1,:)) enddo - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskV) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskV) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskV) maskZ=maskT do j=js_pe-onx,je_pe+onx-1 @@ -212,7 +212,7 @@ subroutine calc_topo maskZ(i,j,:)=min(maskT(i,j,:),maskT(i,j+1,:),maskT(i+1,j,:)) enddo enddo - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskZ) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskZ) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,maskZ) maskW=maskT do k=1,nz-1 @@ -221,14 +221,14 @@ subroutine calc_topo !-------------------------------------------------------------- ! total depth !-------------------------------------------------------------- - ht=0.0;hu=0.0;hv=0.0 + ht=0.0d0;hu=0.0d0;hv=0.0d0 do k=1,nz ht=ht+maskT(:,:,k)*dzt(k) hu=hu+maskU(:,:,k)*dzt(k) hv=hv+maskV(:,:,k)*dzt(k) enddo - where ( hu /= 0.0) hur = 1./hu - where ( hv /= 0.0) hvr = 1./hv + where ( hu /= 0.0d0) hur = 1.d0/hu + where ( hv /= 0.0d0) hvr = 1.d0/hv end subroutine calc_topo @@ -238,21 +238,21 @@ subroutine calc_initial_conditions !-------------------------------------------------------------- ! calculate dyn. enthalp, etc !-------------------------------------------------------------- - use main_module + use main_module implicit none integer :: i,j,k,n real*8 :: fxa,get_rho,get_dyn_enthalpy,get_int_drhodT,get_int_drhodS do n=1,3 ! boundary exchange - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,temp(:,:,:,n)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,temp(:,:,:,n)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,temp(:,:,:,n)) - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,salt(:,:,:,n)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,salt(:,:,:,n)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,salt(:,:,:,n)) ! calculate density, etc do k=1,nz do j=js_pe-onx,je_pe+onx do i=is_pe-onx,ie_pe+onx - if (salt(i,j,k,n) < 0.0) then + if (salt(i,j,k,n) < 0.0d0) then if (my_pe==0) print*,' salinity <0 at i=',i,'j=',j,'k=',k call halt_stop('in main') endif @@ -281,11 +281,11 @@ end subroutine calc_initial_conditions subroutine ugrid_to_tgrid( is_,ie_,js_,je_,nz_,A,B) ! for U-centered boxes, A and B can be identical !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer :: is_,ie_,js_,je_,nz_,i - !real*8 :: A(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) - !real*8 :: B(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) + !real*8 :: A(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) + !real*8 :: B(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) real*8, dimension(is_:ie_,js_:je_,nz_) :: A,B do i=ie_pe,is_pe,-1 !B(i,:,:)=(dxu(i)*A(i,:,:)+dxu(i-1)*A(i-1,:,:))/(dxu(i)+dxu(i-1)) ! error should be 2*dxt(i) below fraction !!!! @@ -297,11 +297,11 @@ end subroutine ugrid_to_tgrid subroutine vgrid_to_tgrid( is_,ie_,js_,je_,nz_,A,B) ! for V-centered boxes, A and B can be identical !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer :: is_,ie_,js_,je_,nz_,j,k - !real*8 :: A(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) - !real*8 :: B(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) + !real*8 :: A(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) + !real*8 :: B(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) real*8, dimension(is_:ie_,js_:je_,nz_) :: A,B do k=1,nz do j=je_pe,js_pe,-1 @@ -329,7 +329,7 @@ subroutine solve_tridiag(a,b,c,d,x,n) real*8,dimension(n) :: cp,dp real*8 :: m,fxa integer i - + ! initialize c-prime and d-prime cp(1) = c(1)/b(1) dp(1) = d(1)/b(1) @@ -355,7 +355,7 @@ end subroutine solve_tridiag subroutine calc_diss( is_,ie_,js_,je_,nz_,diss,K_diss,tag) !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- - use main_module + use main_module implicit none integer :: is_,ie_,js_,je_,nz_ integer :: i,j,k,ks @@ -365,7 +365,7 @@ end subroutine solve_tridiag real*8, dimension(is_:ie_,js_:je_,nz_) :: diss,K_diss,diss_u character*1 :: tag - diss_u=0.0 + diss_u=0.0d0 if (tag == 'U') then ! dissipation interpolated on W-grid @@ -373,9 +373,9 @@ end subroutine solve_tridiag do i=is_pe-1,ie_pe ks=max(kbot(i,j),kbot(i+1,j)) if (ks>0) then - k=ks; diss_u(i,j,k) = 0.5*(diss(i,j,k)+diss(i,j,k+1)) + 0.5*diss(i,j,k)*dzw(max(1,k-1))/dzw(k) + k=ks; diss_u(i,j,k) = 0.5d0*(diss(i,j,k)+diss(i,j,k+1)) + 0.5d0*diss(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - diss_u(i,j,k) = 0.5*(diss(i,j,k) +diss(i,j,k+1)) + diss_u(i,j,k) = 0.5d0*(diss(i,j,k) +diss(i,j,k+1)) enddo k=nz; diss_u(i,j,k) = diss(i,j,k) endif @@ -383,16 +383,16 @@ end subroutine solve_tridiag enddo ! dissipation interpolated from U-grid to T-grid call ugrid_to_tgrid(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss_u,diss_u) - K_diss = K_diss + diss_u + K_diss = K_diss + diss_u else if (tag == 'V') then ! dissipation interpolated on W-grid do j=js_pe-1,je_pe do i=is_pe,ie_pe ks=max(kbot(i,j),kbot(i,j+1)) if (ks>0) then - k=ks; diss_u(i,j,k) = 0.5*(diss(i,j,k)+diss(i,j,k+1)) + 0.5*diss(i,j,k)*dzw(max(1,k-1))/dzw(k) + k=ks; diss_u(i,j,k) = 0.5d0*(diss(i,j,k)+diss(i,j,k+1)) + 0.5d0*diss(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - diss_u(i,j,k) = 0.5*(diss(i,j,k) +diss(i,j,k+1)) + diss_u(i,j,k) = 0.5d0*(diss(i,j,k) +diss(i,j,k+1)) enddo k=nz; diss_u(i,j,k) = diss(i,j,k) endif @@ -400,12 +400,8 @@ end subroutine solve_tridiag enddo ! dissipation interpolated from V-grid to T-grid call vgrid_to_tgrid(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,diss_u,diss_u) - K_diss = K_diss + diss_u + K_diss = K_diss + diss_u else call halt_stop(' unknown tag in subr. vert_diss') endif end subroutine calc_diss - - - - diff --git a/for_src/main/thermodynamics.f90 b/for_src/main/thermodynamics.f90 index 329dff8..f5017ed 100644 --- a/for_src/main/thermodynamics.f90 +++ b/for_src/main/thermodynamics.f90 @@ -7,10 +7,10 @@ subroutine thermodynamics !======================================================================= ! integrate temperature and salinity and diagnose sources of dynamic enthalpy !======================================================================= - use main_module - use isoneutral_module - use tke_module - use timing_module + use main_module + use isoneutral_module + use tke_module + use timing_module implicit none integer :: i,j,k,ks real*8 :: a_tri(nz),b_tri(nz),c_tri(nz),d_tri(nz),delta(nz) @@ -35,9 +35,9 @@ subroutine thermodynamics -(flux_north(i,j,:)- flux_north(i,j-1,:))/(cost(j)*dyt(j)) ) enddo enddo - k=1; dHd(:,:,k,tau)=dHd(:,:,k,tau)-maskT(:,:,k)*flux_top(:,:,k)/dzt(k) + k=1; dHd(:,:,k,tau)=dHd(:,:,k,tau)-maskT(:,:,k)*flux_top(:,:,k)/dzt(k) do k=2,nz - dHd(:,:,k,tau)=dHd(:,:,k,tau)-maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) + dHd(:,:,k,tau)=dHd(:,:,k,tau)-maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) enddo !--------------------------------------------------------------------------------- @@ -45,9 +45,9 @@ subroutine thermodynamics !--------------------------------------------------------------------------------- do k=1,nz do j=js_pe,je_pe - do i=is_pe,ie_pe - fxa = grav/rho_0*( -int_drhodT(i,j,k,tau)*dtemp(i,j,k,tau) -int_drhodS(i,j,k,tau)*dsalt(i,j,k,tau) ) - aloc(i,j,k) =fxa - dHd(i,j,k,tau) + do i=is_pe,ie_pe + fxa = grav/rho_0*( -int_drhodT(i,j,k,tau)*dtemp(i,j,k,tau) -int_drhodS(i,j,k,tau)*dsalt(i,j,k,tau) ) + aloc(i,j,k) =fxa - dHd(i,j,k,tau) enddo enddo enddo @@ -55,10 +55,10 @@ subroutine thermodynamics ! contribution by vertical advection is - g rho w /rho0, substract this also !--------------------------------------------------------------------------------- do k=1,nz-1 - aloc(:,:,k) = aloc(:,:,k) - 0.25*grav/rho_0*w(:,:,k ,tau)*(rho(:,:,k,tau)+rho(:,:,k+1,tau))*dzw(k)/dzt(k) + aloc(:,:,k) = aloc(:,:,k) - 0.25d0*grav/rho_0*w(:,:,k ,tau)*(rho(:,:,k,tau)+rho(:,:,k+1,tau))*dzw(k)/dzt(k) enddo do k=2,nz - aloc(:,:,k) = aloc(:,:,k) - 0.25*grav/rho_0*w(:,:,k-1,tau)*(rho(:,:,k,tau)+rho(:,:,k-1,tau))*dzw(k-1)/dzt(k) + aloc(:,:,k) = aloc(:,:,k) - 0.25d0*grav/rho_0*w(:,:,k-1,tau)*(rho(:,:,k,tau)+rho(:,:,k-1,tau))*dzw(k-1)/dzt(k) enddo endif @@ -70,9 +70,9 @@ subroutine thermodynamics do i=is_pe,ie_pe ks=kbot(i,j) if (ks>0) then - k=ks; P_diss_adv(i,j,k) = 0.5*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) + k=ks; P_diss_adv(i,j,k) = 0.5d0*(aloc(i,j,k)+aloc(i,j,k+1)) + 0.5d0*aloc(i,j,k)*dzw(max(1,k-1))/dzw(k) do k=ks+1,nz-1 - P_diss_adv(i,j,k) = 0.5*(aloc(i,j,k) +aloc(i,j,k+1)) + P_diss_adv(i,j,k) = 0.5d0*(aloc(i,j,k) +aloc(i,j,k+1)) enddo k=nz; P_diss_adv(i,j,k) = aloc(i,j,k) endif @@ -86,23 +86,23 @@ subroutine thermodynamics do j=js_pe,je_pe do i=is_pe,ie_pe fxa = fxa + area_t(i,j)*P_diss_adv(i,j,k)*dzw(k)*maskW(i,j,k) - if (tke(i,j,k,tau) > 0.0 ) fxb = fxb + area_t(i,j)*dzw(k)*maskW(i,j,k) + if (tke(i,j,k,tau) > 0.0d0 ) fxb = fxb + area_t(i,j)*dzw(k)*maskW(i,j,k) enddo enddo enddo k=nz do j=js_pe,je_pe do i=is_pe,ie_pe - fxa = fxa + 0.5*area_t(i,j)*P_diss_adv(i,j,k)*dzw(k)*maskW(i,j,k) - fxb = fxb + 0.5*area_t(i,j)*dzw(k)*maskW(i,j,k) + fxa = fxa + 0.5d0*area_t(i,j)*P_diss_adv(i,j,k)*dzw(k)*maskW(i,j,k) + fxb = fxb + 0.5d0*area_t(i,j)*dzw(k)*maskW(i,j,k) enddo enddo call global_sum(fxa); call global_sum(fxb) - P_diss_adv = 0.0 - do k=1,nz + P_diss_adv = 0.0d0 + do k=1,nz do j=js_pe,je_pe do i=is_pe,ie_pe - if (tke(i,j,k,tau) > 0.0 .or. k==nz) P_diss_adv(i,j,k) = fxa/fxb + if (tke(i,j,k,tau) > 0.0d0 .or. k==nz) P_diss_adv(i,j,k) = fxa/fxb enddo enddo enddo @@ -111,8 +111,8 @@ subroutine thermodynamics !--------------------------------------------------------------------------------- ! Adam Bashforth time stepping for advection !--------------------------------------------------------------------------------- - temp(:,:,:,taup1)=temp(:,:,:,tau)+dt_tracer*( (1.5+AB_eps)*dtemp(:,:,:,tau) - ( 0.5+AB_eps)*dtemp(:,:,:,taum1))*maskT - salt(:,:,:,taup1)=salt(:,:,:,tau)+dt_tracer*( (1.5+AB_eps)*dsalt(:,:,:,tau) - ( 0.5+AB_eps)*dsalt(:,:,:,taum1))*maskT + temp(:,:,:,taup1)=temp(:,:,:,tau)+dt_tracer*( (1.5d0+AB_eps)*dtemp(:,:,:,tau) - ( 0.5d0+AB_eps)*dtemp(:,:,:,taum1))*maskT + salt(:,:,:,taup1)=salt(:,:,:,tau)+dt_tracer*( (1.5d0+AB_eps)*dsalt(:,:,:,tau) - ( 0.5d0+AB_eps)*dsalt(:,:,:,taum1))*maskT !--------------------------------------------------------------------------------- ! horizontal diffusion @@ -130,12 +130,12 @@ subroutine thermodynamics ! isopycnal diffusion !--------------------------------------------------------------------------------- if (enable_neutral_diffusion) then - P_diss_iso = 0.0; dtemp_iso = 0.0; dsalt_iso = 0.0 + P_diss_iso = 0.0d0; dtemp_iso = 0.0d0; dsalt_iso = 0.0d0 call isoneutral_diffusion_pre call isoneutral_diffusion(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,temp,.true.) call isoneutral_diffusion(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,salt,.false.) if (enable_skew_diffusion) then - P_diss_skew = 0.0; + P_diss_skew = 0.0d0; call isoneutral_skew_diffusion(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,temp,.true.) call isoneutral_skew_diffusion(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,salt,.false.) endif @@ -146,8 +146,8 @@ subroutine thermodynamics !--------------------------------------------------------------------------------- ! vertical mixing of temperature and salinity !--------------------------------------------------------------------------------- - dtemp_vmix = temp(:,:,:,taup1) ; dsalt_vmix = salt(:,:,:,taup1) - a_tri=0.0;b_tri=0.0; c_tri=0.0; d_tri=0.0; delta=0.0 + dtemp_vmix = temp(:,:,:,taup1) ; dsalt_vmix = salt(:,:,:,taup1) + a_tri=0.0d0;b_tri=0.0d0; c_tri=0.0d0; d_tri=0.0d0; delta=0.0d0 do j=js_pe,je_pe do i=is_pe,ie_pe ks=kbot(i,j) @@ -155,24 +155,24 @@ subroutine thermodynamics do k=ks,nz-1 delta(k) = dt_tracer/dzw(k)*kappaH(i,j,k) enddo - delta(nz)=0.0 + delta(nz)=0.0d0 do k=ks+1,nz a_tri(k) = - delta(k-1)/dzt(k) enddo - a_tri(ks)=0.0 + a_tri(ks)=0.0d0 do k=ks+1,nz-1 - b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) + b_tri(k) = 1+ delta(k)/dzt(k) + delta(k-1)/dzt(k) enddo - b_tri(nz) = 1+ delta(nz-1)/dzt(nz) - b_tri(ks) = 1+ delta(ks)/dzt(ks) + b_tri(nz) = 1+ delta(nz-1)/dzt(nz) + b_tri(ks) = 1+ delta(ks)/dzt(ks) do k=ks,nz-1 c_tri(k) = - delta(k)/dzt(k) enddo - c_tri(nz)=0.0 - d_tri(ks:nz)=temp(i,j,ks:nz,taup1) + c_tri(nz)=0.0d0 + d_tri(ks:nz)=temp(i,j,ks:nz,taup1) d_tri(nz) = d_tri(nz) + dt_tracer*forc_temp_surface(i,j)/dzt(nz) call solve_tridiag(a_tri(ks:nz),b_tri(ks:nz),c_tri(ks:nz),d_tri(ks:nz),temp(i,j,ks:nz,taup1),nz-ks+1) - d_tri(ks:nz)=salt(i,j,ks:nz,taup1) + d_tri(ks:nz)=salt(i,j,ks:nz,taup1) d_tri(nz) = d_tri(nz) + dt_tracer*forc_salt_surface(i,j)/dzt(nz) call solve_tridiag(a_tri(ks:nz),b_tri(ks:nz),c_tri(ks:nz),d_tri(ks:nz),salt(i,j,ks:nz,taup1),nz-ks+1) endif @@ -184,9 +184,9 @@ subroutine thermodynamics !--------------------------------------------------------------------------------- ! boundary exchange !--------------------------------------------------------------------------------- - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,temp(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,temp(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,temp(:,:,:,taup1)) - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,salt(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,salt(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,salt(:,:,:,taup1)) call tic('eq_of_state') @@ -198,14 +198,14 @@ subroutine thermodynamics !--------------------------------------------------------------------------------- do j=js_pe-onx,je_pe+onx do i=is_pe-onx,ie_pe+onx - forc_rho_surface(i,j)=(get_drhodT(salt(i,j,nz,taup1),temp(i,j,nz,taup1),abs(zt(nz)))*forc_temp_surface(i,j) & + forc_rho_surface(i,j)=(get_drhodT(salt(i,j,nz,taup1),temp(i,j,nz,taup1),abs(zt(nz)))*forc_temp_surface(i,j) & +get_drhodS(salt(i,j,nz,taup1),temp(i,j,nz,taup1),abs(zt(nz)))*forc_salt_surface(i,j) ) & *maskT(i,j,nz) enddo enddo call tic('vmix') - P_diss_v = 0.0 + P_diss_v = 0.0d0 if (enable_conserve_energy) then !--------------------------------------------------------------------------------- ! diagnose dissipation of dynamic enthalpy by vertical mixing @@ -237,14 +237,14 @@ subroutine thermodynamics !--------------------------------------------------------------------------------- ! determine effect due to nonlinear equation of state !--------------------------------------------------------------------------------- - aloc(:,:,1:nz-1)=kappaH(:,:,1:nz-1)*Nsqr(:,:,1:nz-1,taup1) + aloc(:,:,1:nz-1)=kappaH(:,:,1:nz-1)*Nsqr(:,:,1:nz-1,taup1) P_diss_nonlin(:,:,1:nz-1) = P_diss_v(:,:,1:nz-1)-aloc(:,:,1:nz-1) P_diss_v(:,:,1:nz-1) = aloc(:,:,1:nz-1) else !--------------------------------------------------------------------------------- ! diagnose N^2 kappaH, i.e. exchange of pot. energy with TKE !--------------------------------------------------------------------------------- - P_diss_v(:,:,1:nz-1) = kappaH(:,:,1:nz-1)*Nsqr(:,:,1:nz-1,taup1) + P_diss_v(:,:,1:nz-1) = kappaH(:,:,1:nz-1)*Nsqr(:,:,1:nz-1,taup1) P_diss_v(:,:,nz)=-forc_rho_surface(:,:)*maskT(:,:,nz)*grav/rho_0 endif call toc('vmix') @@ -261,7 +261,7 @@ subroutine advect_tracer(is_,ie_,js_,je_,nz_,tr,dtr) !======================================================================= ! calculate time tendency of a tracer due to advection !======================================================================= - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_,nz_ real*8, intent(inout) :: dtr(is_:ie_,js_:je_,nz_),tr(is_:ie_,js_:je_,nz_) @@ -277,9 +277,9 @@ subroutine advect_tracer(is_,ie_,js_,je_,nz_,tr,dtr) -(flux_north(i,j,:)- flux_north(i,j-1,:))/(cost(j)*dyt(j)) ) enddo enddo - k=1; dtr(:,:,k)=dtr(:,:,k)-maskT(:,:,k)*flux_top(:,:,k)/dzt(k) + k=1; dtr(:,:,k)=dtr(:,:,k)-maskT(:,:,k)*flux_top(:,:,k)/dzt(k) do k=2,nz - dtr(:,:,k)=dtr(:,:,k)-maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) + dtr(:,:,k)=dtr(:,:,k)-maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) enddo end subroutine advect_tracer @@ -288,9 +288,9 @@ end subroutine advect_tracer subroutine advect_temperature !======================================================================= -! integrate temperature +! integrate temperature !======================================================================= - use main_module + use main_module implicit none integer :: i,j,k if (enable_superbee_advection) then @@ -304,9 +304,9 @@ subroutine advect_temperature -(flux_north(i,j,:)- flux_north(i,j-1,:))/(cost(j)*dyt(j)) ) enddo enddo - k=1; dtemp(:,:,k,tau)=dtemp(:,:,k,tau)-maskT(:,:,k)*flux_top(:,:,k)/dzt(k) + k=1; dtemp(:,:,k,tau)=dtemp(:,:,k,tau)-maskT(:,:,k)*flux_top(:,:,k)/dzt(k) do k=2,nz - dtemp(:,:,k,tau)=dtemp(:,:,k,tau)-maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) + dtemp(:,:,k,tau)=dtemp(:,:,k,tau)-maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) enddo end subroutine advect_temperature @@ -317,7 +317,7 @@ subroutine advect_salinity !======================================================================= ! integrate salinity !======================================================================= - use main_module + use main_module implicit none integer :: i,j,k if (enable_superbee_advection) then @@ -331,9 +331,9 @@ subroutine advect_salinity -(flux_north(i,j,:)- flux_north(i,j-1,:))/(cost(j)*dyt(j)) ) enddo enddo - k=1; dsalt(:,:,k,tau)=dsalt(:,:,k,tau)-maskT(:,:,k)*flux_top(:,:,k)/dzt(k) + k=1; dsalt(:,:,k,tau)=dsalt(:,:,k,tau)-maskT(:,:,k)*flux_top(:,:,k)/dzt(k) do k=2,nz - dsalt(:,:,k,tau)=dsalt(:,:,k,tau)-maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) + dsalt(:,:,k,tau)=dsalt(:,:,k,tau)-maskT(:,:,k)*(flux_top(:,:,k)- flux_top(:,:,k-1))/dzt(k) enddo end subroutine advect_salinity @@ -341,10 +341,10 @@ end subroutine advect_salinity subroutine calc_eq_of_state(n) !======================================================================= -! calculate density, stability frequency, dynamic enthalpy and derivatives +! calculate density, stability frequency, dynamic enthalpy and derivatives ! for time level n from temperature and salinity !======================================================================= - use main_module + use main_module implicit none integer, intent(in) :: n integer :: i,j,k @@ -391,4 +391,3 @@ subroutine calc_eq_of_state(n) Nsqr(:,:,nz,n)=Nsqr(:,:,nz-1,n) end subroutine calc_eq_of_state - diff --git a/for_src/non_hydrostatic/non_hydrostatic.f90 b/for_src/non_hydrostatic/non_hydrostatic.f90 index 1d02663..27a6c72 100644 --- a/for_src/non_hydrostatic/non_hydrostatic.f90 +++ b/for_src/non_hydrostatic/non_hydrostatic.f90 @@ -15,16 +15,16 @@ subroutine solve_non_hydrostatic ! integrate forward in time !--------------------------------------------------------------------------------- do k=1,nz-1 - w(:,:,k,taup1)=w(:,:,k,tau)+dt_mom*(dw_mix(:,:,k)+(1.5+AB_eps)*dw(:,:,k,tau)-(0.5+AB_eps)*dw(:,:,k,taum1))*maskW(:,:,k) + w(:,:,k,taup1)=w(:,:,k,tau)+dt_mom*(dw_mix(:,:,k)+(1.5d0+AB_eps)*dw(:,:,k,tau)-(0.5d0+AB_eps)*dw(:,:,k,taum1))*maskW(:,:,k) enddo !--------------------------------------------------------------------------------- ! forcing for non-hydrostatic pressure !--------------------------------------------------------------------------------- - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,u(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,u(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,u(:,:,:,taup1)) - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,v(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,v(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,v(:,:,:,taup1)) - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,w(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,w(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,w(:,:,:,taup1)) do j=js_pe,je_pe do i=is_pe,ie_pe @@ -32,9 +32,9 @@ subroutine solve_non_hydrostatic (cosu(j)*v(i,j,:,taup1)-cosu(j-1)*v(i,j-1,:,taup1) )/(cost(j)*dyt(j)) enddo enddo - k=1; forc(:,:,k)= forc(:,:,k) + w(:,:,k,taup1)/dzt(k) + k=1; forc(:,:,k)= forc(:,:,k) + w(:,:,k,taup1)/dzt(k) do k=2,nz - forc(:,:,k)= forc(:,:,k) + (w(:,:,k,taup1)-w(:,:,k-1,taup1) )/dzt(k) + forc(:,:,k)= forc(:,:,k) + (w(:,:,k,taup1)-w(:,:,k-1,taup1) )/dzt(k) enddo forc=forc/dt_mom !--------------------------------------------------------------------------------- @@ -42,9 +42,9 @@ subroutine solve_non_hydrostatic !--------------------------------------------------------------------------------- p_non_hydro(:,:,:,taup1)=2*p_non_hydro(:,:,:,tau)-p_non_hydro(:,:,:,taum1) ! first guess call congrad_non_hydro(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,forc,congr_itts_non_hydro) - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,p_non_hydro(:,:,:,taup1)) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,p_non_hydro(:,:,:,taup1)) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,p_non_hydro(:,:,:,taup1)) - if (itt==0) then + if (itt==0) then p_non_hydro(:,:,:,tau) =p_non_hydro(:,:,:,taup1) p_non_hydro(:,:,:,taum1)=p_non_hydro(:,:,:,taup1) endif @@ -53,12 +53,12 @@ subroutine solve_non_hydrostatic !--------------------------------------------------------------------------------- do j=js_pe,je_pe do i=is_pe,ie_pe - u(i,j,:,taup1) = u(i,j,:,taup1) - dt_mom*( p_non_hydro(i+1,j,:,taup1)-p_non_hydro(i,j,:,taup1))/(dxu(i)*cost(j)) *maskU(i,j,:) - v(i,j,:,taup1) = v(i,j,:,taup1) - dt_mom*( p_non_hydro(i,j+1,:,taup1)-p_non_hydro(i,j,:,taup1)) /dyu(j)*maskV(i,j,:) + u(i,j,:,taup1) = u(i,j,:,taup1) - dt_mom*( p_non_hydro(i+1,j,:,taup1)-p_non_hydro(i,j,:,taup1))/(dxu(i)*cost(j)) *maskU(i,j,:) + v(i,j,:,taup1) = v(i,j,:,taup1) - dt_mom*( p_non_hydro(i,j+1,:,taup1)-p_non_hydro(i,j,:,taup1)) /dyu(j)*maskV(i,j,:) enddo enddo do k=1,nz-1 - w(:,:,k,taup1) = w(:,:,k,taup1) - dt_mom*( p_non_hydro(:,:,k+1,taup1)-p_non_hydro(:,:,k,taup1)) /dzw(k)*maskW(:,:,k) + w(:,:,k,taup1) = w(:,:,k,taup1) - dt_mom*( p_non_hydro(:,:,k+1,taup1)-p_non_hydro(:,:,k,taup1)) /dzw(k)*maskW(:,:,k) enddo end subroutine solve_non_hydrostatic @@ -71,13 +71,13 @@ subroutine make_coeff_non_hydro(is_,ie_,js_,je_,nz_,cf) !======================================================================= ! A * dpsi = forc ! res = A * p -! res = res + cf(...,ii,jj,kk) * p(i+ii,j+jj,k+kk) +! res = res + cf(...,ii,jj,kk) * p(i+ii,j+jj,k+kk) ! ! forc = p_xx + p_yy + p_zz ! forc = (p(i+1) - 2p(i) + p(i-1)) /dx^2 ... -! = [ (p(i+1) - p(i))/dx - (p(i)-p(i-1))/dx ] /dx +! = [ (p(i+1) - p(i))/dx - (p(i)-p(i-1))/dx ] /dx !======================================================================= - use main_module + use main_module implicit none integer :: is_,ie_,js_,je_,nz_ !real*8 :: cf(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz,3,3,3) @@ -110,8 +110,8 @@ subroutine make_coeff_non_hydro(is_,ie_,js_,je_,nz_,cf) do j=js_pe,je_pe do i=is_pe,ie_pe mp=maskW(i,j,k) - cf(i,j,k, 0+2, 0+2, 0+2)= cf(i,j,k, 0+2, 0+2, 0+2)-mp/dzw(k )/dzt(k) - cf(i,j,k, 0+2, 0+2, 1+2)= cf(i,j,k, 0+2, 0+2, 1+2)+mp/dzw(k )/dzt(k) + cf(i,j,k, 0+2, 0+2, 0+2)= cf(i,j,k, 0+2, 0+2, 0+2)-mp/dzw(k )/dzt(k) + cf(i,j,k, 0+2, 0+2, 1+2)= cf(i,j,k, 0+2, 0+2, 1+2)+mp/dzw(k )/dzt(k) enddo enddo do k=2,nz-1 @@ -119,8 +119,8 @@ subroutine make_coeff_non_hydro(is_,ie_,js_,je_,nz_,cf) do i=is_pe,ie_pe mp=maskW(i,j,k) mm=maskW(i,j,k-1) - cf(i,j,k, 0+2, 0+2, 0+2)= cf(i,j,k, 0+2, 0+2, 0+2)-mp/dzw(k )/dzt(k) - cf(i,j,k, 0+2, 0+2, 1+2)= cf(i,j,k, 0+2, 0+2, 1+2)+mp/dzw(k )/dzt(k) + cf(i,j,k, 0+2, 0+2, 0+2)= cf(i,j,k, 0+2, 0+2, 0+2)-mp/dzw(k )/dzt(k) + cf(i,j,k, 0+2, 0+2, 1+2)= cf(i,j,k, 0+2, 0+2, 1+2)+mp/dzw(k )/dzt(k) cf(i,j,k, 0+2, 0+2, 0+2)= cf(i,j,k, 0+2, 0+2, 0+2)-mm/dzw(k-1)/dzt(k) cf(i,j,k, 0+2, 0+2,-1+2)= cf(i,j,k, 0+2, 0+2,-1+2)+mm/dzw(k-1)/dzt(k) enddo @@ -147,7 +147,7 @@ end subroutine make_coeff_non_hydro !======================================================================= ! simple conjugate gradient solver !======================================================================= - use main_module + use main_module implicit none integer :: is_,ie_,js_,je_,nz_ integer :: iterations,n,i,j,k @@ -201,7 +201,7 @@ end subroutine make_coeff_non_hydro rs_min = abs(rsnew) elseif (n .gt. 2) then rs_min = min(rs_min, abs(rsnew)) - if (abs(rsnew) .gt. 100.0*rs_min) then + if (abs(rsnew) .gt. 100.0d0*rs_min) then if (my_pe==0) print'(a,i5,a)','WARNING: non hydrostatic solver diverging after ',n,' iterations' goto 99 endif @@ -214,10 +214,10 @@ end subroutine make_coeff_non_hydro if (n .eq. 1) then step1 = step estimated_error = step - if (step .lt. congr_epsilon_non_hydro) goto 101 + if (step .lt. congr_epsilon_non_hydro) goto 101 else if (step .lt. congr_epsilon_non_hydro) then convergence_rate = exp(log(step/step1)/(n-1)) - estimated_error = step*convergence_rate/(1.0-convergence_rate) + estimated_error = step*convergence_rate/(1.0d0-convergence_rate) if (estimated_error .lt. congr_epsilon_non_hydro) goto 101 end if enddo @@ -243,20 +243,20 @@ end subroutine congrad_non_hydro subroutine apply_op_3D(is_,ie_,js_,je_,nz_,cf, p1, res) - use main_module + use main_module implicit none !----------------------------------------------------------------------- ! apply operator A, res = A *p1 !----------------------------------------------------------------------- integer :: is_,ie_,js_,je_,nz_ - !real*8 :: cf(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz,3,3,3) + !real*8 :: cf(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz,3,3,3) !real*8 :: p1(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) !real*8 :: res(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) - real*8 :: cf(is_:ie_,js_:je_,nz_,3,3,3) + real*8 :: cf(is_:ie_,js_:je_,nz_,3,3,3) real*8, dimension(is_:ie_,js_:je_,nz_) :: p1,res integer :: i,j,k,ii,jj,kk,kpkk - res=0. + res=0.d0 do kk=-1,1 do jj=-1,1 do ii=-1,1 @@ -264,7 +264,7 @@ subroutine apply_op_3D(is_,ie_,js_,je_,nz_,cf, p1, res) kpkk = min(nz,max(1,k+kk)) do j=js_pe,je_pe do i=is_pe,ie_pe - res(i,j,k) = res(i,j,k) + cf(i,j,k,ii+2,jj+2,kk+2)*p1(i+ii,j+jj,kpkk) + res(i,j,k) = res(i,j,k) + cf(i,j,k,ii+2,jj+2,kk+2)*p1(i+ii,j+jj,kpkk) end do end do end do @@ -275,7 +275,7 @@ end subroutine apply_op_3D function absmax_3D(is_,ie_,js_,je_,nz_,p1) - use main_module + use main_module implicit none integer :: is_,ie_,js_,je_,nz_ real*8 :: absmax_3D,s2 @@ -297,7 +297,7 @@ end function absmax_3D function dot_3D(is_,ie_,js_,je_,nz_,p1,p2) - use main_module + use main_module implicit none integer :: is_,ie_,js_,je_,nz_ real*8 :: dot_3D,s2 @@ -317,4 +317,3 @@ function dot_3D(is_,ie_,js_,je_,nz_,p1,p2) call global_sum(s2) dot_3D=s2 end function dot_3D - diff --git a/for_src/parallel/parallel_mpi.f90 b/for_src/parallel/parallel_mpi.f90 index 5d26c07..9089969 100644 --- a/for_src/parallel/parallel_mpi.f90 +++ b/for_src/parallel/parallel_mpi.f90 @@ -2,7 +2,7 @@ subroutine pe_decomposition - use main_module + use main_module implicit none integer :: n,tag=0,iloc(20),ierr include "mpif.h" @@ -43,7 +43,7 @@ subroutine pe_decomposition else n_pes_j = 1; n_pes_i = 1 i_blk = nx; j_blk = ny - my_blk_j = 1 ; my_blk_i = 1 + my_blk_j = 1 ; my_blk_i = 1 js_pe = 1; je_pe = ny is_pe = 1; ie_pe = nx endif @@ -73,7 +73,7 @@ end subroutine pe_decomposition !-------------------------------------------------------------- ! intitialize mpi system for model !-------------------------------------------------------------- - use main_module + use main_module implicit none integer :: comm_,nlen,ierr include "mpif.h" @@ -112,7 +112,7 @@ subroutine fortran_barrier ! A barrier for the local sub domain ! for use in fortran part only !-------------------------------------------------------------- - use main_module + use main_module implicit none integer :: ierr call mpi_barrier(my_comm, ierr) @@ -136,12 +136,12 @@ subroutine my_mpi_test(my_comm) ! try first global barrier call mpi_barrier(my_comm , ierr) ! try broadcasting - xreal = 1.0 + xreal = 1.0d0 call mpi_bcast(xreal,1,mpi_real8,0,my_comm ,ierr) xint = 1 call mpi_bcast(xint,1,mpi_integer,0,my_comm ,ierr) ! check results of broadcasting - if (xreal /= 1.0 ) then + if (xreal /= 1.0d0 ) then print*,'fatal: MPI test failed on broadcasting reals for PE #',my_pe stop endif @@ -151,18 +151,18 @@ subroutine my_mpi_test(my_comm) endif call mpi_barrier(my_comm , ierr) ! try global sum - xreal = 2.0 + xreal = 2.0d0 call mpi_allreduce(xreal,xreal2,1,mpi_real8,MPI_SUM,my_comm ,ierr) xint = 2 call mpi_allreduce(xint,xint2,1,mpi_integer,MPI_SUM,my_comm ,ierr) -! check results +! check results xreal = xreal2/all_pes - if (xreal /= 2.0 ) then + if (xreal /= 2.0d0 ) then print*,'fatal: MPI test failed on global sum (real) for PE #',my_pe stop endif xint = xint2/all_pes - if (xint /= 2.0 ) then + if (xint /= 2.0d0 ) then print*,'fatal: MPI test failed on global sum (int) for PE #',my_pe stop endif @@ -174,7 +174,7 @@ subroutine pe0_bcast_int(a,len) !-------------------------------------------------------------- ! Broadcast an integer vector from pe0 to all other pe !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: len integer, intent(inout) :: a(len) @@ -188,7 +188,7 @@ subroutine pe0_bcast(a,len) !-------------------------------------------------------------- ! Broadcast a vector from pe0 to all other pe !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: len real*8, intent(inout) :: a(len) @@ -203,7 +203,7 @@ subroutine bcast_real(x,len,pe) !-------------------------------------------------------------- ! Broadcast a real vector from PE pe to others !-------------------------------------------------------------- - use main_module + use main_module implicit none integer :: len,ierr,pe real*8 :: x(len) @@ -231,7 +231,7 @@ subroutine global_max(x) !-------------------------------------------------------------- ! Get the max of real x over all PEs in sub domain !-------------------------------------------------------------- - use main_module + use main_module implicit none real*8,intent(inout) :: x real*8 :: x_sym,x_sym2 @@ -247,7 +247,7 @@ subroutine global_min(x) !-------------------------------------------------------------- ! Get the min of real x over all PEs in sub domain !-------------------------------------------------------------- - use main_module + use main_module implicit none real*8,intent(inout) :: x real*8 :: x_sym,x_sym2 @@ -263,7 +263,7 @@ subroutine global_sum(x) !-------------------------------------------------------------- ! Do a sum of real x over all PEs in sub domain !-------------------------------------------------------------- - use main_module + use main_module implicit none real*8,intent(inout) :: x real*8 :: x_sym,x_sym2 @@ -283,7 +283,7 @@ subroutine global_max_int(x) !-------------------------------------------------------------- ! Get the max of integer x over all PEs in sub domain !-------------------------------------------------------------- - use main_module + use main_module implicit none integer,intent(inout) :: x integer :: x_sym,x_sym2,ierr @@ -298,7 +298,7 @@ subroutine global_min_int(x) !-------------------------------------------------------------- ! Get the min of integer x over all PEs in sub domain !-------------------------------------------------------------- - use main_module + use main_module implicit none integer,intent(inout) :: x integer :: x_sym,x_sym2,ierr @@ -313,7 +313,7 @@ subroutine global_sum_int(x) !-------------------------------------------------------------- ! Do a sum of integer x over all PEs in sub domain !-------------------------------------------------------------- - use main_module + use main_module implicit none integer,intent(inout) :: x integer :: x_sym,x_sym2,ierr @@ -331,9 +331,9 @@ end subroutine global_sum_int subroutine border_exchg_xy(is_,ie_,js_,je_,a) !-------------------------------------------------------------- -! Exchange overlapping areas of 2D array a in all PEs of sub domain. +! Exchange overlapping areas of 2D array a in all PEs of sub domain. !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_ real*8, intent(inout) :: a(is_:ie_,js_:je_) @@ -341,7 +341,7 @@ subroutine border_exchg_xy(is_,ie_,js_,je_,a) include "mpif.h" integer,dimension(MPI_STATUS_SIZE) :: Status - + call mpi_barrier(my_comm,ierr) if ( n_pes_j > 1) then ! from north to south @@ -351,13 +351,13 @@ subroutine border_exchg_xy(is_,ie_,js_,je_,a) call mpi_send(a(:,js_pe+j-1),len,mpi_real8,my_pe-n_pes_i,tag,my_comm,ierr) enddo endif - if (my_blk_j /= n_pes_j) then + if (my_blk_j /= n_pes_j) then do j=1,onx call mpi_recv(a(:,je_pe+j),len,mpi_real8,my_pe+n_pes_i,tag,my_comm,Status,ierr) enddo endif ! from south to north - if (my_blk_j /= n_pes_j) then + if (my_blk_j /= n_pes_j) then do j=1,onx call mpi_send(a(:,je_pe-j+1),len,mpi_real8,my_pe+n_pes_i,tag,my_comm,ierr) enddo @@ -378,13 +378,13 @@ subroutine border_exchg_xy(is_,ie_,js_,je_,a) call mpi_send(a(is_pe+i-1,:),len,mpi_real8,my_pe-1,tag,my_comm,ierr) enddo endif - if (my_blk_i /= n_pes_i) then + if (my_blk_i /= n_pes_i) then do i=1,onx call mpi_recv(a(ie_pe+i,:),len,mpi_real8,my_pe+1,tag,my_comm,Status,ierr) enddo endif ! from west to east - if (my_blk_i /= n_pes_i) then + if (my_blk_i /= n_pes_i) then do i=1,onx call mpi_send(a(ie_pe-i+1,:),len,mpi_real8,my_pe+1,tag,my_comm,ierr) enddo @@ -405,9 +405,9 @@ end subroutine border_exchg_xy subroutine border_exchg_xy_int(is_,ie_,js_,je_,a) !-------------------------------------------------------------- -! Exchange overlapping areas of 2D array a in all PEs of sub domain. +! Exchange overlapping areas of 2D array a in all PEs of sub domain. !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_ integer, intent(inout) :: a(is_:ie_,js_:je_) @@ -415,7 +415,7 @@ subroutine border_exchg_xy_int(is_,ie_,js_,je_,a) include "mpif.h" integer,dimension(MPI_STATUS_SIZE) :: Status - + call mpi_barrier(my_comm,ierr) if ( n_pes_j > 1) then ! from north to south @@ -425,13 +425,13 @@ subroutine border_exchg_xy_int(is_,ie_,js_,je_,a) call mpi_send(a(:,js_pe+j-1),len,mpi_integer,my_pe-n_pes_i,tag,my_comm,ierr) enddo endif - if (my_blk_j /= n_pes_j) then + if (my_blk_j /= n_pes_j) then do j=1,onx call mpi_recv(a(:,je_pe+j),len,mpi_integer,my_pe+n_pes_i,tag,my_comm,Status,ierr) enddo endif ! from south to north - if (my_blk_j /= n_pes_j) then + if (my_blk_j /= n_pes_j) then do j=1,onx call mpi_send(a(:,je_pe-j+1),len,mpi_integer,my_pe+n_pes_i,tag,my_comm,ierr) enddo @@ -452,13 +452,13 @@ subroutine border_exchg_xy_int(is_,ie_,js_,je_,a) call mpi_send(a(is_pe+i-1,:),len,mpi_integer,my_pe-1,tag,my_comm,ierr) enddo endif - if (my_blk_i /= n_pes_i) then + if (my_blk_i /= n_pes_i) then do i=1,onx call mpi_recv(a(ie_pe+i,:),len,mpi_integer,my_pe+1,tag,my_comm,Status,ierr) enddo endif ! from west to east - if (my_blk_i /= n_pes_i) then + if (my_blk_i /= n_pes_i) then do i=1,onx call mpi_send(a(ie_pe-i+1,:),len,mpi_integer,my_pe+1,tag,my_comm,ierr) enddo @@ -480,7 +480,7 @@ subroutine setcyclic_xy(is_,ie_,js_,je_,p1) !-------------------------------------------------------------- ! set cyclic boundary conditions for 2D array !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_ real*8,intent(inout) :: p1(is_:ie_,js_:je_) @@ -492,7 +492,7 @@ subroutine setcyclic_xy(is_,ie_,js_,je_,p1) if (n_pes_i == 1) then do i=1,onx p1(nx+i,:)=p1(i ,:) - p1(1-i,:)=p1(nx-i+1,:) + p1(1-i,:)=p1(nx-i+1,:) enddo else len=(je_pe-js_pe+1+2*onx) @@ -518,7 +518,7 @@ subroutine setcyclic_xy_int(is_,ie_,js_,je_,p1) !-------------------------------------------------------------- ! set cyclic boundary conditions for 2D array !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_ integer,intent(inout) :: p1(is_:ie_,js_:je_) @@ -530,7 +530,7 @@ subroutine setcyclic_xy_int(is_,ie_,js_,je_,p1) if (n_pes_i == 1) then do i=1,onx p1(nx+i,:)=p1(i ,:) - p1(1-i,:)=p1(nx-i+1,:) + p1(1-i,:)=p1(nx-i+1,:) enddo else len=(je_pe-js_pe+1+2*onx) @@ -553,25 +553,25 @@ end subroutine setcyclic_xy_int subroutine border_exchg_xyz(is_,ie_,js_,je_,nz_,a) !-------------------------------------------------------------- -! Exchange overlapping areas of 3D array a in all PEs +! Exchange overlapping areas of 3D array a in all PEs !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_,nz_ real*8, intent(inout) :: a(is_:ie_,js_:je_,nz_) integer :: k do k=1,nz - call border_exchg_xy(is_,ie_,js_,je_,a(:,:,k)) + call border_exchg_xy(is_,ie_,js_,je_,a(:,:,k)) enddo end subroutine border_exchg_xyz - + subroutine setcyclic_xyz(is_,ie_,js_,je_,nz_,a) !-------------------------------------------------------------- ! set cyclic boundary conditions for 3D array !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_,nz_ real*8, intent(inout) :: a(is_:ie_,js_:je_,nz_) @@ -586,15 +586,15 @@ end subroutine setcyclic_xyz subroutine border_exchg_xyp(is_,ie_,js_,je_,np,a) !-------------------------------------------------------------- -! Exchange overlapping areas of spectral array a in all PEs +! Exchange overlapping areas of spectral array a in all PEs !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_,np real*8, intent(inout) :: a(is_:ie_,js_:je_,np) integer :: k do k=1,np - call border_exchg_xy(is_,ie_,js_,je_,a(:,:,k)) + call border_exchg_xy(is_,ie_,js_,je_,a(:,:,k)) enddo end subroutine border_exchg_xyp @@ -603,13 +603,13 @@ subroutine setcyclic_xyp(is_,ie_,js_,je_,np,p1) !-------------------------------------------------------------- ! set cyclic boundary conditions for 3D array !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: is_,ie_,js_,je_,np real*8, intent(inout) :: p1(is_:ie_,js_:je_,np) integer :: k - p1(:,:,1 )=p1(:,:,np-1) + p1(:,:,1 )=p1(:,:,np-1) p1(:,:,np)=p1(:,:,2) do k=1,np call setcyclic_xy (is_,ie_,js_,je_,p1(:,:,k)) @@ -624,7 +624,7 @@ subroutine pe0_recv_2D(nx_,ny_,a) !-------------------------------------------------------------- ! all PEs send their data of a 2D array to PE0 !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: nx_,ny_ real*8, intent(inout) :: a(nx_,ny_) @@ -663,7 +663,7 @@ subroutine pe0_recv_2D_int(nx_,ny_,a) !-------------------------------------------------------------- ! all PEs send their data of a 2D array to PE0 !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: nx_,ny_ integer, intent(inout) :: a(nx_,ny_) @@ -703,7 +703,7 @@ subroutine zonal_sum_vec(a,len) ! sum vector along zonal row of PEs ! result is stored in first PE of row !-------------------------------------------------------------- - use main_module + use main_module implicit none integer, intent(in) :: len real*8, intent(inout) :: a(len) @@ -721,10 +721,5 @@ subroutine zonal_sum_vec(a,len) if (my_blk_i==n) call mpi_send(a,len,mpi_real8,my_pe-(my_blk_i-1),tag,my_comm,ierr) endif enddo - endif + endif end subroutine zonal_sum_vec - - - - - diff --git a/for_src/tke/tke.f90 b/for_src/tke/tke.f90 index 18e706d..7226d76 100644 --- a/for_src/tke/tke.f90 +++ b/for_src/tke/tke.f90 @@ -5,9 +5,9 @@ subroutine set_tke_diffusivities !======================================================================= ! set vertical diffusivities based on TKE model !======================================================================= - use main_module - use tke_module - use idemix_module + use main_module + use tke_module + use idemix_module implicit none integer :: k!,kp1,km1 real*8 :: Rinumber(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) @@ -22,14 +22,14 @@ subroutine set_tke_diffusivities mxl = sqrt(2D0)*sqrttke/sqrt(max(1d-12,Nsqr(:,:,:,tau)))*maskW !--------------------------------------------------------------------------------- - ! apply limits for mixing length + ! apply limits for mixing length !--------------------------------------------------------------------------------- if (tke_mxl_choice == 1) then !--------------------------------------------------------------------------------- ! bounded by the distance to surface/bottom !--------------------------------------------------------------------------------- do k=1,nz - mxl(:,:,k) = min(-zw(k)+dzw(k)*0.5,mxl(:,:,k),ht+zw(k)) + mxl(:,:,k) = min(-zw(k)+dzw(k)*0.5d0,mxl(:,:,k),ht+zw(k)) enddo mxl= max(mxl,mxl_min) elseif (tke_mxl_choice == 2) then @@ -51,12 +51,12 @@ subroutine set_tke_diffusivities !--------------------------------------------------------------------------------- ! calculate viscosity and diffusivity based on Prandtl number !--------------------------------------------------------------------------------- - call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,K_diss_v) + call border_exchg_xyz(is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,K_diss_v) call setcyclic_xyz (is_pe-onx,ie_pe+onx,js_pe-onx,je_pe+onx,nz,K_diss_v) KappaM = min(kappaM_max, c_k*mxl*sqrttke ) RiNumber = Nsqr(:,:,:,tau)/max(K_diss_v/max(1d-12,kappaM),1d-12) if (enable_idemix) RiNumber= min(RiNumber,KappaM*Nsqr(:,:,:,tau)/max(1d-12,alpha_c*E_iw(:,:,:,tau)**2)) - PrandtlNumber = max(1d0, min(10d0,6.6* Rinumber)) + PrandtlNumber = max(1d0, min(10d0,6.6d0* Rinumber)) KappaH = KappaM/Prandtlnumber kappaM = max( kappaM_min , kappaM) @@ -67,7 +67,7 @@ subroutine set_tke_diffusivities !--------------------------------------------------------------------------------- ! simple convective adjustment !--------------------------------------------------------------------------------- - where (Nsqr(:,:,:,tau)< 0.0) kappaH = 1.0 + where (Nsqr(:,:,:,tau)< 0.0d0) kappaH = 1.0d0 endif endif end subroutine set_tke_diffusivities @@ -78,10 +78,10 @@ subroutine integrate_tke !======================================================================= ! integrate Tke equation on W grid with surface flux boundary condition !======================================================================= - use main_module - use eke_module - use tke_module - use idemix_module + use main_module + use eke_module + use tke_module + use idemix_module implicit none integer :: i,j,k,ks,ke real*8 :: a_tri(nz),b_tri(nz),c_tri(nz),d_tri(nz),delta(nz) @@ -95,7 +95,7 @@ subroutine integrate_tke forc = K_diss_v - P_diss_v - P_diss_adv !--------------------------------------------------------------------------------- - ! store transfer due to vertical mixing from dyn. enthalpy by non-linear eq.of + ! store transfer due to vertical mixing from dyn. enthalpy by non-linear eq.of ! state either to TKE or to heat !--------------------------------------------------------------------------------- if (.not. enable_store_cabbeling_heat) forc = forc - P_diss_nonlin @@ -116,7 +116,7 @@ subroutine integrate_tke if (enable_store_bottom_friction_tke) forc = forc + K_diss_bot else ! short-cut without idemix if (enable_eke) then - forc = forc + eke_diss_iw + forc = forc + eke_diss_iw else ! and without EKE model if (enable_store_cabbeling_heat) then forc = forc + K_diss_gm + K_diss_h - P_diss_skew - P_diss_hmix - P_diss_iso @@ -137,26 +137,26 @@ subroutine integrate_tke ks=kbot(i,j) if (ks>0) then do k=ks,ke-1 - delta(k) = dt_tke/dzt(k+1)*alpha_tke*0.5*(kappaM(i,j,k)+kappaM(i,j,k+1)) + delta(k) = dt_tke/dzt(k+1)*alpha_tke*0.5d0*(kappaM(i,j,k)+kappaM(i,j,k+1)) enddo - delta(ke)=0.0 + delta(ke)=0.0d0 do k=ks+1,ke-1 a_tri(k) = - delta(k-1)/dzw(k) enddo - a_tri(ks)=0.0 - a_tri(ke) = - delta(ke-1)/(0.5*dzw(ke)) + a_tri(ks)=0.0d0 + a_tri(ke) = - delta(ke-1)/(0.5d0*dzw(ke)) do k=ks+1,ke-1 b_tri(k) = 1+ delta(k)/dzw(k) + delta(k-1)/dzw(k) + dt_tke*c_eps*sqrttke(i,j,k)/mxl(i,j,k) enddo - b_tri(ke) = 1+ delta(ke-1)/(0.5*dzw(ke)) + dt_tke*c_eps/mxl(i,j,ke)*sqrttke(i,j,ke) - b_tri(ks) = 1+ delta(ks)/dzw(ks) + dt_tke*c_eps/mxl(i,j,ks)*sqrttke(i,j,ks) + b_tri(ke) = 1+ delta(ke-1)/(0.5d0*dzw(ke)) + dt_tke*c_eps/mxl(i,j,ke)*sqrttke(i,j,ke) + b_tri(ks) = 1+ delta(ks)/dzw(ks) + dt_tke*c_eps/mxl(i,j,ks)*sqrttke(i,j,ks) do k=ks,ke-1 c_tri(k) = - delta(k)/dzw(k) enddo - c_tri(ke)=0.0 + c_tri(ke)=0.0d0 d_tri(ks:ke)=tke(i,j,ks:ke,tau) + dt_tke*forc(i,j,ks:ke) - d_tri(ks) = d_tri(ks) - d_tri(ke) = d_tri(ke) + dt_tke*forc_tke_surface(i,j)/(0.5*dzw(ke)) + d_tri(ks) = d_tri(ks) + d_tri(ke) = d_tri(ke) + dt_tke*forc_tke_surface(i,j)/(0.5d0*dzw(ke)) call solve_tridiag(a_tri(ks:ke),b_tri(ks:ke),c_tri(ks:ke),d_tri(ks:ke),tke(i,j,ks:ke,taup1),ke-ks+1) endif enddo @@ -174,12 +174,12 @@ subroutine integrate_tke !--------------------------------------------------------------------------------- ! Add TKE if surface density flux drains TKE in uppermost box !--------------------------------------------------------------------------------- - tke_surf_corr = 0.0 + tke_surf_corr = 0.0d0 do j=js_pe,je_pe do i=is_pe,ie_pe - if (tke(i,j,nz,taup1) < 0.0 ) then - tke_surf_corr(i,j) = -tke(i,j,nz,taup1)*(0.5*dzw(ke)) /dt_tke - tke(i,j,nz,taup1) = 0.0 + if (tke(i,j,nz,taup1) < 0.0d0 ) then + tke_surf_corr(i,j) = -tke(i,j,nz,taup1)*(0.5d0*dzw(ke)) /dt_tke + tke(i,j,nz,taup1) = 0.0d0 endif enddo enddo @@ -193,11 +193,11 @@ subroutine integrate_tke flux_east(i,j,:)=K_h_tke*(tke(i+1,j,:,tau)-tke(i,j,:,tau))/(cost(j)*dxu(i))*maskU(i,j,:) enddo enddo - flux_east(ie_pe-onx,:,:)=0. + flux_east(ie_pe-onx,:,:)=0.d0 do j=js_pe-onx,je_pe+onx-1 flux_north(:,j,:)=K_h_tke*(tke(:,j+1,:,tau)-tke(:,j,:,tau))/dyu(j)*maskV(:,j,:)*cosu(j) enddo - flux_north(:,je_pe+onx,:)=0. + flux_north(:,je_pe+onx,:)=0.d0 do j=js_pe,je_pe do i=is_pe,ie_pe tke(i,j,:,taup1)= tke(i,j,:,taup1) + dt_tke*maskW(i,j,:)* & @@ -223,22 +223,16 @@ subroutine integrate_tke -(flux_north(i,j,:)- flux_north(i,j-1,:))/(cost(j)*dyt(j)) ) enddo enddo - k=1; dtke(:,:,k,tau)=dtke(:,:,k,tau)-flux_top(:,:,k)/dzw(k) + k=1; dtke(:,:,k,tau)=dtke(:,:,k,tau)-flux_top(:,:,k)/dzw(k) do k=2,nz-1 - dtke(:,:,k,tau)=dtke(:,:,k,tau)-(flux_top(:,:,k)- flux_top(:,:,k-1))/dzw(k) + dtke(:,:,k,tau)=dtke(:,:,k,tau)-(flux_top(:,:,k)- flux_top(:,:,k-1))/dzw(k) enddo k=nz - dtke(:,:,k,tau)=dtke(:,:,k,tau)-(flux_top(:,:,k)- flux_top(:,:,k-1))/(0.5*dzw(k)) + dtke(:,:,k,tau)=dtke(:,:,k,tau)-(flux_top(:,:,k)- flux_top(:,:,k-1))/(0.5d0*dzw(k)) !--------------------------------------------------------------------------------- ! Adam Bashforth time stepping !--------------------------------------------------------------------------------- - tke(:,:,:,taup1)=tke(:,:,:,taup1)+dt_tracer*( (1.5+AB_eps)*dtke(:,:,:,tau) - ( 0.5+AB_eps)*dtke(:,:,:,taum1)) + tke(:,:,:,taup1)=tke(:,:,:,taup1)+dt_tracer*( (1.5d0+AB_eps)*dtke(:,:,:,tau) - ( 0.5d0+AB_eps)*dtke(:,:,:,taum1)) endif end subroutine integrate_tke - - - - - - diff --git a/for_src/tke/tke_module.f90 b/for_src/tke/tke_module.f90 index dc68b4e..1efcd16 100644 --- a/for_src/tke/tke_module.f90 +++ b/for_src/tke/tke_module.f90 @@ -12,13 +12,13 @@ module tke_module real*8, allocatable :: tke(:,:,:,:) ! small-scale tke real*8, allocatable :: mxl(:,:,:) ! eddy length scale real*8, allocatable :: sqrttke(:,:,:) ! square root of TKE - real*8, allocatable :: Prandtlnumber(:,:,:) - real*8, allocatable :: forc_tke_surface(:,:) - real*8, allocatable :: tke_surf_corr(:,:) - real*8, allocatable :: tke_diss(:,:,:) - real*8 :: c_k = 0.1 - real*8 :: c_eps = 0.7 - real*8 :: alpha_tke = 1.0 + real*8, allocatable :: Prandtlnumber(:,:,:) + real*8, allocatable :: forc_tke_surface(:,:) + real*8, allocatable :: tke_surf_corr(:,:) + real*8, allocatable :: tke_diss(:,:,:) + real*8 :: c_k = 0.1d0 + real*8 :: c_eps = 0.7d0 + real*8 :: alpha_tke = 1.0d0 real*8 :: mxl_min = 1d-12 real*8 :: kappaM_min = 0.d0 real*8 :: kappaM_max = 100.d0 @@ -27,7 +27,7 @@ module tke_module logical :: enable_tke_superbee_advection = .false. logical :: enable_tke_upwind_advection = .false. logical :: enable_tke_hor_diffusion = .false. - real*8 :: K_h_tke = 2000.0 ! lateral diffusivity for tke + real*8 :: K_h_tke = 2000.0d0 ! lateral diffusivity for tke end module tke_module @@ -36,13 +36,13 @@ subroutine allocate_tke_module use tke_module if (enable_tke) then - allocate(dtke(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz,3) );dtke = 0.0 - allocate( tke(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz,3) ); tke = 0.0 + allocate(dtke(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz,3) );dtke = 0.0d0 + allocate( tke(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz,3) ); tke = 0.0d0 allocate( mxl(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); mxl = 0 allocate( sqrttke(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); sqrttke = 0 allocate( Prandtlnumber(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); Prandtlnumber = 0 allocate( forc_tke_surface(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx) ); forc_tke_surface = 0 - allocate( tke_diss(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); tke_diss = 0.0 + allocate( tke_diss(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx,nz) ); tke_diss = 0.0d0 allocate( tke_surf_corr(is_pe-onx:ie_pe+onx,js_pe-onx:je_pe+onx) ); tke_surf_corr = 0 endif