Skip to content
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

Modify files in sat_vapor_pres directory #4

Merged
merged 8 commits into from
Oct 18, 2021
Merged

Modify files in sat_vapor_pres directory #4

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
84fb687
Modify set_tracer_profile in tracer_manager.F90
MinsukJi-NOAA Oct 8, 2021
ba92db8
Specify platform_mod variables used
MinsukJi-NOAA Oct 8, 2021
8a47920
Merge remote-tracking branch 'emc/fms_mixedmode' into feature/mji_mix…
MinsukJi-NOAA Oct 8, 2021
4b63ab9
Modify real_to_time_type in time_manager.F90
MinsukJi-NOAA Oct 9, 2021
fbe2aa2
Merge remote-tracking branch 'emc/fms_mixedmode' into feature/mji_mix…
MinsukJi-NOAA Oct 9, 2021
a9d1638
Modify files in the sat_vapor_pres directory
MinsukJi-NOAA Oct 10, 2021
07ef656
Fix select type statement in sat_vapor_pres_k.F90
MinsukJi-NOAA Oct 10, 2021
d68a06c
Move write temp statement inside select type
MinsukJi-NOAA Oct 10, 2021
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
245 changes: 167 additions & 78 deletions sat_vapor_pres/sat_vapor_pres.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -194,6 +194,8 @@ module sat_vapor_pres_mod
lookup_des3_k, lookup_es3_des3_k, &
compute_qs_k, compute_mrs_k

use platform_mod, only: r4_kind, r8_kind

implicit none
private

Expand Down Expand Up @@ -739,8 +741,8 @@ module sat_vapor_pres_mod
! </SUBROUTINE>
subroutine lookup_es_0d ( temp, esat, err_msg )

real, intent(in) :: temp
real, intent(out) :: esat
class(*), intent(in) :: temp
class(*), intent(out) :: esat
character(len=*), intent(out), optional :: err_msg

integer :: nbad
Expand Down Expand Up @@ -771,8 +773,8 @@ end subroutine lookup_es_0d
! </SUBROUTINE>
subroutine lookup_es_1d ( temp, esat, err_msg )

real, intent(in) :: temp(:)
real, intent(out) :: esat(:)
class(*), intent(in) :: temp(:)
class(*), intent(out) :: esat(:)
character(len=*), intent(out), optional :: err_msg

character(len=54) :: err_msg_local
Expand Down Expand Up @@ -807,8 +809,8 @@ end subroutine lookup_es_1d
! </SUBROUTINE>
subroutine lookup_es_2d ( temp, esat, err_msg )

real, intent(in) :: temp(:,:)
real, intent(out) :: esat(:,:)
class(*), intent(in) :: temp(:,:)
class(*), intent(out) :: esat(:,:)
character(len=*), intent(out), optional :: err_msg

character(len=54) :: err_msg_local
Expand Down Expand Up @@ -843,8 +845,8 @@ end subroutine lookup_es_2d
! </SUBROUTINE>
subroutine lookup_es_3d ( temp, esat, err_msg )

real, intent(in) :: temp(:,:,:)
real, intent(out) :: esat(:,:,:)
class(*), intent(in) :: temp(:,:,:)
class(*), intent(out) :: esat(:,:,:)
character(len=*), intent(out), optional :: err_msg

integer :: nbad
Expand Down Expand Up @@ -1975,10 +1977,10 @@ end subroutine lookup_es3_des3_3d
subroutine compute_qs_0d ( temp, press, qsat, q, hc, dqsdT, esat, &
err_msg, es_over_liq, es_over_liq_and_ice )

real, intent(in) :: temp, press
real, intent(out) :: qsat
real, intent(in), optional :: q, hc
real, intent(out), optional :: dqsdT, esat
class(*), intent(in) :: temp, press
class(*), intent(out) :: qsat
class(*), intent(in), optional :: q, hc
class(*), intent(out), optional :: dqsdT, esat
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
Expand Down Expand Up @@ -2033,11 +2035,11 @@ end subroutine compute_qs_0d
subroutine compute_qs_1d ( temp, press, qsat, q, hc, dqsdT, esat, &
err_msg, es_over_liq, es_over_liq_and_ice )

real, intent(in) :: temp(:), press(:)
real, intent(out) :: qsat(:)
real, intent(in), optional :: q(:)
real, intent(in), optional :: hc
real, intent(out), optional :: dqsdT(:), esat(:)
class(*), intent(in) :: temp(:), press(:)
class(*), intent(out) :: qsat(:)
class(*), intent(in), optional :: q(:)
class(*), intent(in), optional :: hc
class(*), intent(out), optional :: dqsdT(:), esat(:)
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
Expand Down Expand Up @@ -2095,11 +2097,11 @@ end subroutine compute_qs_1d
subroutine compute_qs_2d ( temp, press, qsat, q, hc, dqsdT, esat, &
err_msg, es_over_liq, es_over_liq_and_ice )

real, intent(in) :: temp(:,:), press(:,:)
real, intent(out) :: qsat(:,:)
real, intent(in), optional :: q(:,:)
real, intent(in), optional :: hc
real, intent(out), optional :: dqsdT(:,:), esat(:,:)
class(*), intent(in) :: temp(:,:), press(:,:)
class(*), intent(out) :: qsat(:,:)
class(*), intent(in), optional :: q(:,:)
class(*), intent(in), optional :: hc
class(*), intent(out), optional :: dqsdT(:,:), esat(:,:)
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
Expand Down Expand Up @@ -2156,11 +2158,11 @@ end subroutine compute_qs_2d
subroutine compute_qs_3d ( temp, press, qsat, q, hc, dqsdT, esat, &
err_msg, es_over_liq, es_over_liq_and_ice )

real, intent(in) :: temp(:,:,:), press(:,:,:)
real, intent(out) :: qsat(:,:,:)
real, intent(in), optional :: q(:,:,:)
real, intent(in), optional :: hc
real, intent(out), optional :: dqsdT(:,:,:), esat(:,:,:)
class(*), intent(in) :: temp(:,:,:), press(:,:,:)
class(*), intent(out) :: qsat(:,:,:)
class(*), intent(in), optional :: q(:,:,:)
class(*), intent(in), optional :: hc
class(*), intent(out), optional :: dqsdT(:,:,:), esat(:,:,:)
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
Expand Down Expand Up @@ -2608,131 +2610,218 @@ end subroutine sat_vapor_pres_init
!#######################################################################

function check_1d ( temp ) result ( nbad )
real , intent(in) :: temp(:)
class(*), intent(in) :: temp(:)
integer :: nbad, ind, i

nbad = 0
do i = 1, size(temp,1)
ind = int(dtinv*(temp(i)-tmin+teps))
if (ind < 0 .or. ind > nlim) nbad = nbad+1
enddo

select type (temp)
type is (real(kind=r4_kind))
do i = 1, size(temp,1)
ind = int(dtinv*(temp(i)-tmin+teps))
if (ind < 0 .or. ind > nlim) nbad = nbad+1
enddo
type is (real(kind=r8_kind))
do i = 1, size(temp,1)
ind = int(dtinv*(temp(i)-tmin+teps))
if (ind < 0 .or. ind > nlim) nbad = nbad+1
enddo
end select

end function check_1d

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

function check_2d ( temp ) result ( nbad )
real , intent(in) :: temp(:,:)
class(*), intent(in) :: temp(:,:)
integer :: nbad
integer :: j

nbad = 0
do j = 1, size(temp,2)
nbad = nbad + check_1d ( temp(:,j) )
enddo
nbad = 0

select type (temp)
type is (real(kind=r4_kind))
do j = 1, size(temp,2)
nbad = nbad + check_1d ( temp(:,j) )
enddo
type is (real(kind=r8_kind))
do j = 1, size(temp,2)
nbad = nbad + check_1d ( temp(:,j) )
enddo
end select

end function check_2d

!#######################################################################

subroutine temp_check_1d ( temp )
real , intent(in) :: temp(:)
class(*), intent(in) :: temp(:)
integer :: i, unit

unit = stdoutunit
write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1))

select type (temp)
type is (real(kind=r4_kind))
write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1))
type is (real(kind=r8_kind))
write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1))
end select

end subroutine temp_check_1d

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

subroutine temp_check_2d ( temp )
real , intent(in) :: temp(:,:)
class(*), intent(in) :: temp(:,:)
integer :: i, j, unit

unit = stdoutunit
write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1))
write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2))

select type (temp)
type is (real(kind=r4_kind))
write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1))
write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2))
type is (real(kind=r8_kind))
write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1))
write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2))
end select

end subroutine temp_check_2d

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

subroutine temp_check_3d ( temp )
real, intent(in) :: temp(:,:,:)
class(*), intent(in) :: temp(:,:,:)
integer :: i, j, k, unit

unit = stdoutunit
write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1))
write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2))
write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3))

select type (temp)
type is (real(kind=r4_kind))
write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1))
write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2))
write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3))
type is (real(kind=r8_kind))
write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1))
write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2))
write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3))
end select

end subroutine temp_check_3d

!#######################################################################

subroutine show_all_bad_0d ( temp )
real , intent(in) :: temp
class(*), intent(in) :: temp
integer :: ind, unit

unit = stdoutunit
ind = int(dtinv*(temp-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe()
endif

select type (temp)
type is (real(kind=r4_kind))
ind = int(dtinv*(temp-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe()
endif
type is (real(kind=r8_kind))
ind = int(dtinv*(temp-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe()
endif
end select

end subroutine show_all_bad_0d

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

subroutine show_all_bad_1d ( temp )
real , intent(in) :: temp(:)
class(*), intent(in) :: temp(:)
integer :: i, ind, unit

unit = stdoutunit
do i=1,size(temp)
ind = int(dtinv*(temp(i)-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe()
endif
enddo

select type (temp)
type is (real(kind=r4_kind))
do i=1,size(temp)
ind = int(dtinv*(temp(i)-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe()
endif
enddo
type is (real(kind=r8_kind))
do i=1,size(temp)
ind = int(dtinv*(temp(i)-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe()
endif
enddo
end select

end subroutine show_all_bad_1d

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

subroutine show_all_bad_2d ( temp )
real , intent(in) :: temp(:,:)
class(*), intent(in) :: temp(:,:)
integer :: i, j, ind, unit

unit = stdoutunit
do j=1,size(temp,2)
do i=1,size(temp,1)
ind = int(dtinv*(temp(i,j)-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe()
endif
enddo
enddo

select type (temp)
type is (real(kind=r4_kind))
do j=1,size(temp,2)
do i=1,size(temp,1)
ind = int(dtinv*(temp(i,j)-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe()
endif
enddo
enddo
type is (real(kind=r8_kind))
do j=1,size(temp,2)
do i=1,size(temp,1)
ind = int(dtinv*(temp(i,j)-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe()
endif
enddo
enddo
end select

end subroutine show_all_bad_2d

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

subroutine show_all_bad_3d ( temp )
real, intent(in) :: temp(:,:,:)
class(*), intent(in) :: temp(:,:,:)
integer :: i, j, k, ind, unit

unit = stdoutunit
do k=1,size(temp,3)
do j=1,size(temp,2)
do i=1,size(temp,1)
ind = int(dtinv*(temp(i,j,k)-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe()
endif
enddo
enddo
enddo

select type (temp)
type is (real(kind=r4_kind))
do k=1,size(temp,3)
do j=1,size(temp,2)
do i=1,size(temp,1)
ind = int(dtinv*(temp(i,j,k)-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe()
endif
enddo
enddo
enddo
type is (real(kind=r8_kind))
do k=1,size(temp,3)
do j=1,size(temp,2)
do i=1,size(temp,1)
ind = int(dtinv*(temp(i,j,k)-tmin+teps))
if (ind < 0 .or. ind > nlim) then
write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe()
endif
enddo
enddo
enddo
end select

end subroutine show_all_bad_3d

Expand Down
Loading