Skip to content

Commit

Permalink
Modify files in sat_vapor_pres directory (#4)
Browse files Browse the repository at this point in the history 
* Modify set_tracer_profile in tracer_manager.F90
* Specify platform_mod variables used
* Modify real_to_time_type in time_manager.F90
* Modify files in the sat_vapor_pres directory
* Fix select type statement in sat_vapor_pres_k.F90
* Move write temp statement inside select type
  • Loading branch information
@MinsukJi-NOAA
MinsukJi-NOAA authored Oct 18, 2021
1 parent 6418dfa commit 64a4504
Show file tree
Hide file tree
Showing 2 changed files with 1,909 additions and 730 deletions.
245 changes: 167 additions & 78 deletions sat_vapor_pres/sat_vapor_pres.F90
View file
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

0 comments on commit 64a4504

Please sign in to comment.