Skip to content

Correct several Fortran 2008 compliance issues in physics_mmm #1086

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 3 commits into from
Jun 15, 2023
Merged

Correct several Fortran 2008 compliance issues in physics_mmm #1086

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
bf3fc7c
Correct Fortran 2008 compliance in cu_ntiedtke.F
mgduda Jun 15, 2023
f56ee3c
Correct Fortran 2008 compliance in module_libmassv.F
mgduda Jun 15, 2023
1a3eed0
Address Fortran 2008 compliance in mp_radar.F
mgduda Jun 15, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
24 changes: 16 additions & 8 deletions src/core_atmosphere/physics/physics_mmm/cu_ntiedtke.F
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2527,9 +2527,10 @@ subroutine cudlfsn &
implicit none

!--- input arguments:
integer,intent(in):: klon
logical,intent(in),dimension(klon):: ldcum

integer,intent(in):: klev,klon
integer,intent(in):: klev
integer,intent(in),dimension(klon):: lndj
integer,intent(in),dimension(klon):: kcbot,kctop

Expand Down Expand Up @@ -2737,9 +2738,10 @@ subroutine cuddrafn &
implicit none

!--- input arguments:
integer,intent(in)::klon
logical,intent(in),dimension(klon):: lddraf

integer,intent(in)::klev,klon
integer,intent(in)::klev

real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh,puen,pven
real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo,pmfu
Expand Down Expand Up @@ -2980,9 +2982,10 @@ subroutine cuflxn &
implicit none

!--- input arguments:
integer,intent(in):: klon
logical,intent(in),dimension(klon):: ldcum

integer,intent(in):: klev,klon
integer,intent(in):: klev
integer,intent(in),dimension(klon):: lndj
integer,intent(in),dimension(klon):: kcbot,kctop,kdtop

Expand Down Expand Up @@ -3237,9 +3240,10 @@ subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, &
implicit none

!--- input arguments:
integer,intent(in):: klon
logical,intent(in),dimension(klon):: ldcum,lddraf

integer,intent(in):: klon,klev,ktopm2
integer,intent(in):: klev,ktopm2
integer,intent(in),dimension(klon):: kctop,kdtop

real(kind=kind_phys),intent(in):: ztmst
Expand Down Expand Up @@ -3323,8 +3327,9 @@ subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, &
implicit none

!--- input arguments:
integer,intent(in):: klon
logical,intent(in),dimension(klon):: ldcum
integer,intent(in):: klon,klev,ktopm2
integer,intent(in):: klev,ktopm2
integer,intent(in),dimension(klon):: ktype,kcbot,kctop

real(kind=kind_phys),intent(in):: ztmst
Expand Down Expand Up @@ -3466,8 +3471,9 @@ subroutine cuadjtqn &
implicit none

!--- input arguments:
integer,intent(in):: klon
logical,intent(in),dimension(klon):: ldflag
integer,intent(in):: kcall,kk,klev,klon
integer,intent(in):: kcall,kk,klev

real(kind=kind_phys),intent(in),dimension(klon):: psp

Expand Down Expand Up @@ -3597,8 +3603,9 @@ subroutine cubasmcn &
! ----------------------------------------------------------------

!--- input arguments:
integer,intent(in):: klon
logical,intent(in),dimension(klon):: ldcum
integer,intent(in):: klon,kk,klev,klevm1
integer,intent(in):: kk,klev,klevm1

real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,pgeo,pverv
real(kind=kind_phys),intent(in),dimension(klon,klev):: puen,pven ! not used.
Expand Down Expand Up @@ -3657,9 +3664,10 @@ subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, &

!--- input arguments:
logical,intent(in):: ldwork
integer,intent(in):: klon
logical,intent(in),dimension(klon):: ldcum

integer,intent(in):: klon,klev,kk
integer,intent(in):: klev,kk
integer,intent(in),dimension(klon):: kcbot

real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu
Expand Down
22 changes: 12 additions & 10 deletions src/core_atmosphere/physics/physics_mmm/module_libmassv.F
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,8 @@ module module_libmassv
module procedure vsqrt_s
end interface

integer, parameter, private :: R4KIND = selected_real_kind(6)
integer, parameter, private :: R8KIND = selected_real_kind(12)

contains

Expand All @@ -22,14 +24,14 @@ module module_libmassv
subroutine vrec_d(y,x,n)
!=================================================================================================================
integer,intent(in):: n
real*8,dimension(*),intent(in):: x
real*8,dimension(*),intent(out):: y
real(kind=R8KIND),dimension(*),intent(in):: x
real(kind=R8KIND),dimension(*),intent(out):: y

integer:: j
!-----------------------------------------------------------------------------------------------------------------

do j=1,n
y(j)=1.d0/x(j)
y(j)=real(1.0,kind=R8KIND)/x(j)
enddo

end subroutine vrec_d
Expand All @@ -38,14 +40,14 @@ end subroutine vrec_d
subroutine vrec_s(y,x,n)
!=================================================================================================================
integer,intent(in):: n
real*4,dimension(*),intent(in):: x
real*4,dimension(*),intent(out):: y
real(kind=R4KIND),dimension(*),intent(in):: x
real(kind=R4KIND),dimension(*),intent(out):: y

integer:: j
!-----------------------------------------------------------------------------------------------------------------

do j=1,n
y(j)=1.e0/x(j)
y(j)=real(1.0,kind=R4KIND)/x(j)
enddo

end subroutine vrec_s
Expand All @@ -54,8 +56,8 @@ end subroutine vrec_s
subroutine vsqrt_d(y,x,n)
!=================================================================================================================
integer,intent(in):: n
real*8,dimension(*),intent(in):: x
real*8,dimension(*),intent(out):: y
real(kind=R8KIND),dimension(*),intent(in):: x
real(kind=R8KIND),dimension(*),intent(out):: y

integer:: j
!-----------------------------------------------------------------------------------------------------------------
Expand All @@ -71,8 +73,8 @@ subroutine vsqrt_s(y,x,n)
!=================================================================================================================

integer,intent(in):: n
real*4,dimension(*),intent(in):: x
real*4,dimension(*),intent(out):: y
real(kind=R4KIND),dimension(*),intent(in):: x
real(kind=R4KIND),dimension(*),intent(out):: y

integer:: j

Expand Down
37 changes: 20 additions & 17 deletions src/core_atmosphere/physics/physics_mmm/mp_radar.F
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,9 @@ module mp_radar
!.. calculations based on 50 individual size bins of the distributions.
!+---+-----------------------------------------------------------------+

integer, parameter, private :: R4KIND = selected_real_kind(6)
integer, parameter, private :: R8KIND = selected_real_kind(12)

integer,parameter,public:: nrbins = 50
integer,parameter,public:: slen = 20
character(len=slen), public:: &
Expand All @@ -38,7 +41,7 @@ module mp_radar
mixingrulestring_g, matrixstring_g, inclusionstring_g, &
hoststring_g, hostmatrixstring_g, hostinclusionstring_g

complex*16,public:: m_w_0, m_i_0
complex(kind=R8KIND),public:: m_w_0, m_i_0

double precision,dimension(nrbins+1),public:: xxdx
double precision,dimension(nrbins),public:: xxds,xdts,xxdg,xdtg
Expand Down Expand Up @@ -123,7 +126,7 @@ subroutine radar_init
xxdx(1) = 100.d-6
xxdx(nrbins+1) = 0.02d0
do n = 2, nrbins
xxdx(n) = dexp(dfloat(n-1)/dfloat(nrbins) &
xxdx(n) = dexp(real(n-1,kind=R8KIND)/real(nrbins,kind=R8KIND) &
* dlog(xxdx(nrbins+1)/xxdx(1)) +dlog(xxdx(1)))
enddo
do n = 1, nrbins
Expand All @@ -135,7 +138,7 @@ subroutine radar_init
xxdx(1) = 100.d-6
xxdx(nrbins+1) = 0.05d0
do n = 2, nrbins
xxdx(n) = dexp(dfloat(n-1)/dfloat(nrbins) &
xxdx(n) = dexp(real(n-1,kind=R8KIND)/real(nrbins,kind=R8KIND) &
* dlog(xxdx(nrbins+1)/xxdx(1)) +dlog(xxdx(1)))
enddo
do n = 1, nrbins
Expand Down Expand Up @@ -196,7 +199,7 @@ subroutine rayleigh_soak_wetgraupel(x_g,a_geo,b_geo,fmelt,meltratio_outside,m_w,
character(len=*), intent(in):: mixingrule, matrix, inclusion, &
host, hostmatrix, hostinclusion

complex*16,intent(in):: m_w, m_i
complex(kind=R8KIND),intent(in):: m_w, m_i

double precision, intent(in):: x_g, a_geo, b_geo, fmelt, lambda, meltratio_outside

Expand All @@ -206,7 +209,7 @@ subroutine rayleigh_soak_wetgraupel(x_g,a_geo,b_geo,fmelt,meltratio_outside,m_w,
!--- local variables:
integer:: error

complex*16:: m_core, m_air
complex(kind=R8KIND):: m_core, m_air

double precision, parameter:: pix=3.1415926535897932384626434d0
double precision:: d_large, d_g, rhog, x_w, xw_a, fm, fmgrenz, &
Expand Down Expand Up @@ -340,7 +343,7 @@ real(kind=kind_phys) function gammln(xx)
end function gammln

!=================================================================================================================
complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, &
complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, &
volice, volwater, mixingrule, host, matrix, &
inclusion, hostmatrix, hostinclusion, cumulerror)
implicit none
Expand All @@ -350,7 +353,7 @@ complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, &
character(len=*),intent(in):: mixingrule, host, matrix, &
inclusion, hostmatrix, hostinclusion

complex*16,intent(in):: m_a, m_i, m_w
complex(kind=R8KIND),intent(in):: m_a, m_i, m_w

double precision,intent(in):: volice, volair, volwater

Expand All @@ -360,7 +363,7 @@ complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, &
!--- local variables:
integer:: error

complex*16:: mtmp
complex(kind=R8KIND):: mtmp

double precision:: vol1, vol2

Expand Down Expand Up @@ -481,7 +484,7 @@ complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, &
end function get_m_mix_nested

!=================================================================================================================
complex*16 function get_m_mix (m_a, m_i, m_w, volair, volice, &
complex(kind=R8KIND) function get_m_mix (m_a, m_i, m_w, volair, volice, &
volwater, mixingrule, matrix, inclusion, &
error)
implicit none
Expand All @@ -490,7 +493,7 @@ complex*16 function get_m_mix (m_a, m_i, m_w, volair, volice, &
!--- input arguments:
character(len=*),intent(in):: mixingrule, matrix, inclusion

complex*16, intent(in):: m_a, m_i, m_w
complex(kind=R8KIND), intent(in):: m_a, m_i, m_w

double precision, intent(in):: volice, volair, volwater

Expand Down Expand Up @@ -531,15 +534,15 @@ complex*16 function get_m_mix (m_a, m_i, m_w, volair, volice, &
end function get_m_mix

!=================================================================================================================
complex*16 function m_complex_maxwellgarnett(vol1, vol2, vol3, &
complex(kind=R8KIND) function m_complex_maxwellgarnett(vol1, vol2, vol3, &
m1, m2, m3, inclusion, error)
implicit none
!=================================================================================================================

!--- input arguments:
character(len=*),intent(in):: inclusion

complex*16,intent(in):: m1,m2,m3
complex(kind=R8KIND),intent(in):: m1,m2,m3

double precision,intent(in):: vol1,vol2,vol3

Expand All @@ -548,7 +551,7 @@ complex*16 function m_complex_maxwellgarnett(vol1, vol2, vol3, &
integer,intent(out):: error

!--- local variables:
complex*16 :: beta2, beta3, m1t, m2t, m3t
complex(kind=R8KIND) :: beta2, beta3, m1t, m2t, m3t

!-----------------------------------------------------------------------------------------------------------------

Expand Down Expand Up @@ -576,7 +579,7 @@ complex*16 function m_complex_maxwellgarnett(vol1, vol2, vol3, &
else
write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: ', 'unknown inclusion: ', inclusion
call physics_message(radar_debug)
m_complex_maxwellgarnett=dcmplx(-999.99d0,-999.99d0)
m_complex_maxwellgarnett=cmplx(-999.99d0,-999.99d0,kind=R8KIND)
error = 1
return
endif
Expand All @@ -587,7 +590,7 @@ complex*16 function m_complex_maxwellgarnett(vol1, vol2, vol3, &
end function m_complex_maxwellgarnett

!=================================================================================================================
complex*16 function m_complex_water_ray(lambda,t)
complex(kind=R8KIND) function m_complex_water_ray(lambda,t)
implicit none
!=================================================================================================================

Expand All @@ -603,7 +606,7 @@ complex*16 function m_complex_water_ray(lambda,t)
double precision,parameter:: pix=3.1415926535897932384626434d0
double precision:: epsinf,epss,epsr,epsi
double precision:: alpha,lambdas,sigma,nenner
complex*16,parameter:: i = (0d0,1d0)
complex(kind=R8KIND),parameter:: i = (0d0,1d0)

!-----------------------------------------------------------------------------------------------------------------

Expand All @@ -627,7 +630,7 @@ complex*16 function m_complex_water_ray(lambda,t)
end function m_complex_water_ray

!=================================================================================================================
complex*16 function m_complex_ice_maetzler(lambda,t)
complex(kind=R8KIND) function m_complex_ice_maetzler(lambda,t)
implicit none
!=================================================================================================================

Expand Down