8 use mom_eos_linear,
only : calculate_specvol_derivs_linear, int_density_dz_linear
10 use mom_eos_linear,
only : calculate_compress_linear, int_spec_vol_dp_linear
13 use mom_eos_wright,
only : calculate_specvol_derivs_wright, int_density_dz_wright
14 use mom_eos_wright,
only : calculate_compress_wright, int_spec_vol_dp_wright
35 implicit none ;
private
37 #include <MOM_memory.h>
42 public eos_init, eos_manual_init, eos_end, eos_allocate
44 public int_density_dz, int_specific_vol_dp
45 public int_density_dz_generic_plm, int_density_dz_generic_ppm
46 public int_spec_vol_dp_generic_plm
47 public int_density_dz_generic, int_spec_vol_dp_generic
48 public find_depth_of_pressure_in_cell
50 public convert_temp_salt_for_teos10
51 public gsw_sp_from_sr, gsw_pt_from_ct
52 public extract_member_eos
61 module procedure calculate_density_scalar, calculate_density_array
66 module procedure calculate_spec_vol_scalar, calculate_spec_vol_array
71 module procedure calculate_density_derivs_scalar, calculate_density_derivs_array
77 module procedure calculate_density_second_derivs_scalar, calculate_density_second_derivs_array
82 module procedure calculate_tfreeze_scalar, calculate_tfreeze_array
87 integer :: form_of_eos = 0
88 integer :: form_of_tfreeze = 0
90 logical :: eos_quadrature
92 logical :: compressible = .true.
107 integer,
parameter,
public :: eos_linear = 1
108 integer,
parameter,
public :: eos_unesco = 2
109 integer,
parameter,
public :: eos_wright = 3
110 integer,
parameter,
public :: eos_teos10 = 4
111 integer,
parameter,
public :: eos_nemo = 5
113 character*(10),
parameter :: eos_linear_string =
"LINEAR"
114 character*(10),
parameter :: eos_unesco_string =
"UNESCO"
115 character*(10),
parameter :: eos_wright_string =
"WRIGHT"
116 character*(10),
parameter :: eos_teos10_string =
"TEOS10"
117 character*(10),
parameter :: eos_nemo_string =
"NEMO"
118 character*(10),
parameter :: eos_default = eos_wright_string
120 integer,
parameter :: tfreeze_linear = 1
121 integer,
parameter :: tfreeze_millero = 2
122 integer,
parameter :: tfreeze_teos10 = 3
123 character*(10),
parameter :: tfreeze_linear_string =
"LINEAR"
124 character*(10),
parameter :: tfreeze_millero_string =
"MILLERO_78"
126 character*(10),
parameter :: tfreeze_teos10_string =
"TEOS10"
127 character*(10),
parameter :: tfreeze_default = tfreeze_linear_string
133 subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref)
134 real,
intent(in) :: T
135 real,
intent(in) :: S
136 real,
intent(in) :: pressure
137 real,
intent(out) :: rho
139 real,
optional,
intent(in) :: rho_ref
141 if (.not.
associated(eos))
call mom_error(fatal, &
142 "calculate_density_scalar called with an unassociated EOS_type EOS.")
144 select case (eos%form_of_EOS)
147 eos%Rho_T0_S0, eos%dRho_dT, eos%dRho_dS, rho_ref)
157 call mom_error(fatal, &
158 "calculate_density_scalar: EOS is not valid.")
161 end subroutine calculate_density_scalar
165 subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref)
166 real,
dimension(:),
intent(in) :: T
167 real,
dimension(:),
intent(in) :: S
168 real,
dimension(:),
intent(in) :: pressure
169 real,
dimension(:),
intent(out) :: rho
170 integer,
intent(in) :: start
171 integer,
intent(in) :: npts
173 real,
optional,
intent(in) :: rho_ref
175 if (.not.
associated(eos))
call mom_error(fatal, &
176 "calculate_density_array called with an unassociated EOS_type EOS.")
178 select case (eos%form_of_EOS)
181 eos%Rho_T0_S0, eos%dRho_dT, eos%dRho_dS, rho_ref)
191 call mom_error(fatal, &
192 "calculate_density_array: EOS%form_of_EOS is not valid.")
195 end subroutine calculate_density_array
199 subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref)
200 real,
intent(in) :: T
201 real,
intent(in) :: S
202 real,
intent(in) :: pressure
203 real,
intent(out) :: specvol
205 real,
optional,
intent(in) :: spv_ref
209 if (.not.
associated(eos))
call mom_error(fatal, &
210 "calculate_spec_vol_scalar called with an unassociated EOS_type EOS.")
212 select case (eos%form_of_EOS)
215 eos%rho_T0_S0, eos%drho_dT, eos%drho_dS, spv_ref)
224 if (
present(spv_ref))
then
225 specvol = 1.0 / rho - spv_ref
230 call mom_error(fatal, &
231 "calculate_spec_vol_scalar: EOS is not valid.")
234 end subroutine calculate_spec_vol_scalar
239 subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref)
240 real,
dimension(:),
intent(in) :: T
242 real,
dimension(:),
intent(in) :: S
243 real,
dimension(:),
intent(in) :: pressure
244 real,
dimension(:),
intent(out) :: specvol
245 integer,
intent(in) :: start
246 integer,
intent(in) :: npts
248 real,
optional,
intent(in) :: spv_ref
250 real,
dimension(size(specvol)) :: rho
253 if (.not.
associated(eos))
call mom_error(fatal, &
254 "calculate_spec_vol_array called with an unassociated EOS_type EOS.")
256 select case (eos%form_of_EOS)
259 eos%rho_T0_S0, eos%drho_dT, eos%drho_dS, spv_ref)
268 if (
present(spv_ref))
then
269 specvol(:) = 1.0 / rho(:) - spv_ref
271 specvol(:) = 1.0 / rho(:)
274 call mom_error(fatal, &
275 "calculate_spec_vol_array: EOS%form_of_EOS is not valid.")
278 end subroutine calculate_spec_vol_array
282 subroutine calculate_tfreeze_scalar(S, pressure, T_fr, EOS)
283 real,
intent(in) :: S
284 real,
intent(in) :: pressure
285 real,
intent(out) :: T_fr
289 if (.not.
associated(eos))
call mom_error(fatal, &
290 "calculate_TFreeze_scalar called with an unassociated EOS_type EOS.")
292 select case (eos%form_of_TFreeze)
293 case (tfreeze_linear)
295 eos%dTFr_dS, eos%dTFr_dp)
296 case (tfreeze_millero)
298 case (tfreeze_teos10)
301 call mom_error(fatal, &
302 "calculate_TFreeze_scalar: form_of_TFreeze is not valid.")
305 end subroutine calculate_tfreeze_scalar
308 subroutine calculate_tfreeze_array(S, pressure, T_fr, start, npts, EOS)
309 real,
dimension(:),
intent(in) :: S
310 real,
dimension(:),
intent(in) :: pressure
311 real,
dimension(:),
intent(out) :: T_fr
313 integer,
intent(in) :: start
314 integer,
intent(in) :: npts
317 if (.not.
associated(eos))
call mom_error(fatal, &
318 "calculate_TFreeze_scalar called with an unassociated EOS_type EOS.")
320 select case (eos%form_of_TFreeze)
321 case (tfreeze_linear)
323 eos%TFr_S0_P0, eos%dTFr_dS, eos%dTFr_dp)
324 case (tfreeze_millero)
326 case (tfreeze_teos10)
329 call mom_error(fatal, &
330 "calculate_TFreeze_scalar: form_of_TFreeze is not valid.")
333 end subroutine calculate_tfreeze_array
336 subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS)
337 real,
dimension(:),
intent(in) :: T
338 real,
dimension(:),
intent(in) :: S
339 real,
dimension(:),
intent(in) :: pressure
340 real,
dimension(:),
intent(out) :: drho_dT
342 real,
dimension(:),
intent(out) :: drho_dS
344 integer,
intent(in) :: start
345 integer,
intent(in) :: npts
348 if (.not.
associated(eos))
call mom_error(fatal, &
349 "calculate_density_derivs called with an unassociated EOS_type EOS.")
351 select case (eos%form_of_EOS)
354 eos%dRho_dT, eos%dRho_dS, start, npts)
356 call calculate_density_derivs_unesco(t, s, pressure, drho_dt, drho_ds, start, npts)
364 call mom_error(fatal, &
365 "calculate_density_derivs_array: EOS%form_of_EOS is not valid.")
368 end subroutine calculate_density_derivs_array
372 subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS)
373 real,
intent(in) :: T
374 real,
intent(in) :: S
375 real,
intent(in) :: pressure
376 real,
intent(out) :: drho_dT
378 real,
intent(out) :: drho_dS
381 if (.not.
associated(eos))
call mom_error(fatal, &
382 "calculate_density_derivs called with an unassociated EOS_type EOS.")
384 select case (eos%form_of_EOS)
387 eos%Rho_T0_S0, eos%dRho_dT, eos%dRho_dS)
393 call mom_error(fatal, &
394 "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.")
397 end subroutine calculate_density_derivs_scalar
400 subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, &
401 drho_dS_dP, drho_dT_dP, start, npts, EOS)
402 real,
dimension(:),
intent(in) :: T
403 real,
dimension(:),
intent(in) :: S
404 real,
dimension(:),
intent(in) :: pressure
405 real,
dimension(:),
intent(out) :: drho_dS_dS
407 real,
dimension(:),
intent(out) :: drho_dS_dT
409 real,
dimension(:),
intent(out) :: drho_dT_dT
411 real,
dimension(:),
intent(out) :: drho_dS_dP
413 real,
dimension(:),
intent(out) :: drho_dT_dP
415 integer,
intent(in) :: start
416 integer,
intent(in) :: npts
419 if (.not.
associated(eos))
call mom_error(fatal, &
420 "calculate_density_derivs called with an unassociated EOS_type EOS.")
422 select case (eos%form_of_EOS)
425 drho_dt_dt, drho_ds_dp, drho_dt_dp, start, npts)
428 drho_dt_dt, drho_ds_dp, drho_dt_dp, start, npts)
431 drho_dt_dt, drho_ds_dp, drho_dt_dp, start, npts)
433 call mom_error(fatal, &
434 "calculate_density_derivs: EOS%form_of_EOS is not valid.")
437 end subroutine calculate_density_second_derivs_array
440 subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, &
441 drho_dS_dP, drho_dT_dP, EOS)
442 real,
intent(in) :: T
443 real,
intent(in) :: S
444 real,
intent(in) :: pressure
445 real,
intent(out) :: drho_dS_dS
447 real,
intent(out) :: drho_dS_dT
449 real,
intent(out) :: drho_dT_dT
451 real,
intent(out) :: drho_dS_dP
453 real,
intent(out) :: drho_dT_dP
457 if (.not.
associated(eos))
call mom_error(fatal, &
458 "calculate_density_derivs called with an unassociated EOS_type EOS.")
460 select case (eos%form_of_EOS)
463 drho_dt_dt, drho_ds_dp, drho_dt_dp)
466 drho_dt_dt, drho_ds_dp, drho_dt_dp)
469 drho_dt_dt, drho_ds_dp, drho_dt_dp)
471 call mom_error(fatal, &
472 "calculate_density_derivs: EOS%form_of_EOS is not valid.")
475 end subroutine calculate_density_second_derivs_scalar
478 subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS)
479 real,
dimension(:),
intent(in) :: t
480 real,
dimension(:),
intent(in) :: s
481 real,
dimension(:),
intent(in) :: pressure
482 real,
dimension(:),
intent(out) :: dsv_dt
484 real,
dimension(:),
intent(out) :: dsv_ds
486 integer,
intent(in) :: start
487 integer,
intent(in) :: npts
490 real,
dimension(size(T)) :: drho_dt, drho_ds, rho
493 if (.not.
associated(eos))
call mom_error(fatal, &
494 "calculate_density_derivs called with an unassociated EOS_type EOS.")
496 select case (eos%form_of_EOS)
498 call calculate_specvol_derivs_linear(t, s, pressure, dsv_dt, dsv_ds, start, &
499 npts, eos%Rho_T0_S0, eos%dRho_dT, eos%dRho_dS)
502 call calculate_density_derivs_unesco(t, s, pressure, drho_dt, drho_ds, start, npts)
503 do j=start,start+npts-1
504 dsv_dt(j) = -drho_dt(j)/(rho(j)**2)
505 dsv_ds(j) = -drho_ds(j)/(rho(j)**2)
508 call calculate_specvol_derivs_wright(t, s, pressure, dsv_dt, dsv_ds, start, npts)
510 call calculate_specvol_derivs_teos10(t, s, pressure, dsv_dt, dsv_ds, start, npts)
514 do j=start,start+npts-1
515 dsv_dt(j) = -drho_dt(j)/(rho(j)**2)
516 dsv_ds(j) = -drho_ds(j)/(rho(j)**2)
519 call mom_error(fatal, &
520 "calculate_density_derivs: EOS%form_of_EOS is not valid.")
523 end subroutine calculate_specific_vol_derivs
526 subroutine calculate_compress(T, S, pressure, rho, drho_dp, start, npts, EOS)
527 real,
dimension(:),
intent(in) :: t
528 real,
dimension(:),
intent(in) :: s
529 real,
dimension(:),
intent(in) :: pressure
530 real,
dimension(:),
intent(out) :: rho
531 real,
dimension(:),
intent(out) :: drho_dp
533 integer,
intent(in) :: start
534 integer,
intent(in) :: npts
537 if (.not.
associated(eos))
call mom_error(fatal, &
538 "calculate_compress called with an unassociated EOS_type EOS.")
540 select case (eos%form_of_EOS)
542 call calculate_compress_linear(t, s, pressure, rho, drho_dp, start, npts, &
543 eos%Rho_T0_S0, eos%dRho_dT, eos%dRho_dS)
545 call calculate_compress_unesco(t, s, pressure, rho, drho_dp, start, npts)
547 call calculate_compress_wright(t, s, pressure, rho, drho_dp, start, npts)
549 call calculate_compress_teos10(t, s, pressure, rho, drho_dp, start, npts)
551 call calculate_compress_nemo(t, s, pressure, rho, drho_dp, start, npts)
553 call mom_error(fatal, &
554 "calculate_compress: EOS%form_of_EOS is not valid.")
557 end subroutine calculate_compress
565 subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, &
566 dza, intp_dza, intx_dza, inty_dza, halo_size, &
567 bathyP, dP_tiny, useMassWghtInterp)
569 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
571 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
573 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
575 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
577 real,
intent(in) :: alpha_ref
582 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
585 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
586 optional,
intent(out) :: intp_dza
589 real,
dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), &
590 optional,
intent(out) :: intx_dza
593 real,
dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), &
594 optional,
intent(out) :: inty_dza
597 integer,
optional,
intent(in) :: halo_size
598 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
599 optional,
intent(in) :: bathyp
600 real,
optional,
intent(in) :: dp_tiny
602 logical,
optional,
intent(in) :: usemasswghtinterp
605 if (.not.
associated(eos))
call mom_error(fatal, &
606 "int_specific_vol_dp called with an unassociated EOS_type EOS.")
608 if (eos%EOS_quadrature)
then
609 call int_spec_vol_dp_generic(t, s, p_t, p_b, alpha_ref, hi, eos, &
610 dza, intp_dza, intx_dza, inty_dza, halo_size, &
611 bathyp, dp_tiny, usemasswghtinterp)
612 else ;
select case (eos%form_of_EOS)
614 call int_spec_vol_dp_linear(t, s, p_t, p_b, alpha_ref, hi, eos%Rho_T0_S0, &
615 eos%dRho_dT, eos%dRho_dS, dza, intp_dza, &
616 intx_dza, inty_dza, halo_size, &
617 bathyp, dp_tiny, usemasswghtinterp)
619 call int_spec_vol_dp_wright(t, s, p_t, p_b, alpha_ref, hi, dza, &
620 intp_dza, intx_dza, inty_dza, halo_size, &
621 bathyp, dp_tiny, usemasswghtinterp)
623 call int_spec_vol_dp_generic(t, s, p_t, p_b, alpha_ref, hi, eos, &
624 dza, intp_dza, intx_dza, inty_dza, halo_size, &
625 bathyp, dp_tiny, usemasswghtinterp)
628 end subroutine int_specific_vol_dp
633 subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, &
634 dpa, intz_dpa, intx_dpa, inty_dpa, &
635 bathyT, dz_neglect, useMassWghtInterp)
638 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
640 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
642 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
644 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
646 real,
intent(in) :: rho_ref
648 real,
intent(in) :: rho_0
650 real,
intent(in) :: g_e
652 real,
dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), &
654 real,
dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), &
655 optional,
intent(out) :: intz_dpa
658 real,
dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), &
659 optional,
intent(out) :: intx_dpa
662 real,
dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), &
663 optional,
intent(out) :: inty_dpa
666 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
667 optional,
intent(in) :: bathyt
668 real,
optional,
intent(in) :: dz_neglect
669 logical,
optional,
intent(in) :: usemasswghtinterp
672 if (.not.
associated(eos))
call mom_error(fatal, &
673 "int_density_dz called with an unassociated EOS_type EOS.")
675 if (eos%EOS_quadrature)
then
676 call int_density_dz_generic(t, s, z_t, z_b, rho_ref, rho_0, g_e, hii, hio, &
677 eos, dpa, intz_dpa, intx_dpa, inty_dpa, &
678 bathyt, dz_neglect, usemasswghtinterp)
679 else ;
select case (eos%form_of_EOS)
681 call int_density_dz_linear(t, s, z_t, z_b, rho_ref, rho_0, g_e, hii, hio, &
682 eos%Rho_T0_S0, eos%dRho_dT, eos%dRho_dS, &
683 dpa, intz_dpa, intx_dpa, inty_dpa, &
684 bathyt, dz_neglect, usemasswghtinterp)
686 call int_density_dz_wright(t, s, z_t, z_b, rho_ref, rho_0, g_e, hii, hio, &
687 dpa, intz_dpa, intx_dpa, inty_dpa, &
688 bathyt, dz_neglect, usemasswghtinterp)
690 call int_density_dz_generic(t, s, z_t, z_b, rho_ref, rho_0, g_e, hii, hio, &
691 eos, dpa, intz_dpa, intx_dpa, inty_dpa, &
692 bathyt, dz_neglect, usemasswghtinterp)
695 end subroutine int_density_dz
698 logical function query_compressible(EOS)
701 if (.not.
associated(eos))
call mom_error(fatal, &
702 "query_compressible called with an unassociated EOS_type EOS.")
704 query_compressible = eos%compressible
705 end function query_compressible
708 subroutine eos_init(param_file, EOS)
712 #include "version_variable.h"
713 character(len=40) :: mdl =
"MOM_EOS"
714 character(len=40) :: tmpstr
716 if (.not.
associated(eos))
call eos_allocate(eos)
721 call get_param(param_file, mdl,
"EQN_OF_STATE", tmpstr, &
722 "EQN_OF_STATE determines which ocean equation of state "//&
723 "should be used. Currently, the valid choices are "//&
724 '"LINEAR", "UNESCO", "WRIGHT", "NEMO" and "TEOS10". '//&
725 "This is only used if USE_EOS is true.", default=eos_default)
726 select case (uppercase(tmpstr))
727 case (eos_linear_string)
728 eos%form_of_EOS = eos_linear
729 case (eos_unesco_string)
730 eos%form_of_EOS = eos_unesco
731 case (eos_wright_string)
732 eos%form_of_EOS = eos_wright
733 case (eos_teos10_string)
734 eos%form_of_EOS = eos_teos10
735 case (eos_nemo_string)
736 eos%form_of_EOS = eos_nemo
738 call mom_error(fatal,
"interpret_eos_selection: EQN_OF_STATE "//&
739 trim(tmpstr) //
"in input file is invalid.")
741 call mom_mesg(
'interpret_eos_selection: equation of state set to "' // &
742 trim(tmpstr)//
'"', 5)
744 if (eos%form_of_EOS == eos_linear)
then
745 eos%Compressible = .false.
746 call get_param(param_file, mdl,
"RHO_T0_S0", eos%Rho_T0_S0, &
747 "When EQN_OF_STATE="//trim(eos_linear_string)//
", "//&
748 "this is the density at T=0, S=0.", units=
"kg m-3", &
750 call get_param(param_file, mdl,
"DRHO_DT", eos%dRho_dT, &
751 "When EQN_OF_STATE="//trim(eos_linear_string)//
", "//&
752 "this is the partial derivative of density with "//&
753 "temperature.", units=
"kg m-3 K-1", default=-0.2)
754 call get_param(param_file, mdl,
"DRHO_DS", eos%dRho_dS, &
755 "When EQN_OF_STATE="//trim(eos_linear_string)//
", "//&
756 "this is the partial derivative of density with "//&
757 "salinity.", units=
"kg m-3 PSU-1", default=0.8)
760 call get_param(param_file, mdl,
"EOS_QUADRATURE", eos%EOS_quadrature, &
761 "If true, always use the generic (quadrature) code "//&
762 "code for the integrals of density.", default=.false.)
764 call get_param(param_file, mdl,
"TFREEZE_FORM", tmpstr, &
765 "TFREEZE_FORM determines which expression should be "//&
766 "used for the freezing point. Currently, the valid "//&
767 'choices are "LINEAR", "MILLERO_78", "TEOS10"', &
768 default=tfreeze_default)
769 select case (uppercase(tmpstr))
770 case (tfreeze_linear_string)
771 eos%form_of_TFreeze = tfreeze_linear
772 case (tfreeze_millero_string)
773 eos%form_of_TFreeze = tfreeze_millero
774 case (tfreeze_teos10_string)
775 eos%form_of_TFreeze = tfreeze_teos10
777 call mom_error(fatal,
"interpret_eos_selection: TFREEZE_FORM "//&
778 trim(tmpstr) //
"in input file is invalid.")
781 if (eos%form_of_TFreeze == tfreeze_linear)
then
782 call get_param(param_file, mdl,
"TFREEZE_S0_P0",eos%TFr_S0_P0, &
783 "When TFREEZE_FORM="//trim(tfreeze_linear_string)//
", "//&
784 "this is the freezing potential temperature at "//&
785 "S=0, P=0.", units=
"deg C", default=0.0)
786 call get_param(param_file, mdl,
"DTFREEZE_DS",eos%dTFr_dS, &
787 "When TFREEZE_FORM="//trim(tfreeze_linear_string)//
", "//&
788 "this is the derivative of the freezing potential "//&
789 "temperature with salinity.", &
790 units=
"deg C PSU-1", default=-0.054)
791 call get_param(param_file, mdl,
"DTFREEZE_DP",eos%dTFr_dP, &
792 "When TFREEZE_FORM="//trim(tfreeze_linear_string)//
", "//&
793 "this is the derivative of the freezing potential "//&
794 "temperature with pressure.", &
795 units=
"deg C Pa-1", default=0.0)
798 if ((eos%form_of_EOS == eos_teos10 .OR. eos%form_of_EOS == eos_nemo) .AND. &
799 eos%form_of_TFreeze /= tfreeze_teos10)
then
800 call mom_error(fatal,
"interpret_eos_selection: EOS_TEOS10 or EOS_NEMO \n" //&
801 "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .")
805 end subroutine eos_init
808 subroutine eos_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, &
809 Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp)
811 integer,
optional,
intent(in) :: form_of_eos
812 integer,
optional,
intent(in) :: form_of_tfreeze
814 logical,
optional,
intent(in) :: eos_quadrature
816 logical,
optional,
intent(in) :: compressible
817 real ,
optional,
intent(in) :: rho_t0_s0
818 real ,
optional,
intent(in) :: drho_dt
820 real ,
optional,
intent(in) :: drho_ds
822 real ,
optional,
intent(in) :: tfr_s0_p0
823 real ,
optional,
intent(in) :: dtfr_ds
825 real ,
optional,
intent(in) :: dtfr_dp
828 if (
present(form_of_eos )) eos%form_of_EOS = form_of_eos
829 if (
present(form_of_tfreeze)) eos%form_of_TFreeze = form_of_tfreeze
830 if (
present(eos_quadrature )) eos%EOS_quadrature = eos_quadrature
831 if (
present(compressible )) eos%Compressible = compressible
832 if (
present(rho_t0_s0 )) eos%Rho_T0_S0 = rho_t0_s0
833 if (
present(drho_dt )) eos%drho_dT = drho_dt
834 if (
present(drho_ds )) eos%dRho_dS = drho_ds
835 if (
present(tfr_s0_p0 )) eos%TFr_S0_P0 = tfr_s0_p0
836 if (
present(dtfr_ds )) eos%dTFr_dS = dtfr_ds
837 if (
present(dtfr_dp )) eos%dTFr_dp = dtfr_dp
839 end subroutine eos_manual_init
842 subroutine eos_allocate(EOS)
845 if (.not.
associated(eos))
allocate(eos)
846 end subroutine eos_allocate
849 subroutine eos_end(EOS)
852 if (
associated(eos))
deallocate(eos)
853 end subroutine eos_end
860 subroutine eos_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature)
861 real,
intent(in) :: rho_t0_s0
862 real,
intent(in) :: drho_dt
863 real,
intent(in) :: drho_ds
864 logical,
optional,
intent(in) :: use_quadrature
868 if (.not.
associated(eos))
call mom_error(fatal, &
869 "MOM_EOS.F90: EOS_use_linear() called with an unassociated EOS_type EOS.")
871 eos%form_of_EOS = eos_linear
872 eos%Compressible = .false.
873 eos%Rho_T0_S0 = rho_t0_s0
874 eos%dRho_dT = drho_dt
875 eos%dRho_dS = drho_ds
876 eos%EOS_quadrature = .false.
877 if (
present(use_quadrature)) eos%EOS_quadrature = use_quadrature
879 end subroutine eos_use_linear
884 subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, &
885 EOS, dpa, intz_dpa, intx_dpa, inty_dpa, &
886 bathyT, dz_neglect, useMassWghtInterp)
889 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
891 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
893 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
895 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
897 real,
intent(in) :: rho_ref
900 real,
intent(in) :: rho_0
903 real,
intent(in) :: g_e
905 real,
dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), &
908 real,
dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), &
909 optional,
intent(out) :: intz_dpa
912 real,
dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), &
913 optional,
intent(out) :: intx_dpa
916 real,
dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), &
917 optional,
intent(out) :: inty_dpa
920 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
921 optional,
intent(in) :: bathyt
922 real,
optional,
intent(in) :: dz_neglect
923 logical,
optional,
intent(in) :: usemasswghtinterp
925 real :: t5(5), s5(5), p5(5), r5(5)
927 real :: w_left, w_right
928 real,
parameter :: c1_90 = 1.0/90.0
934 real :: hwt_ll, hwt_lr
935 real :: hwt_rl, hwt_rr
940 logical :: do_massweight
941 integer :: is, ie, js, je, isq, ieq, jsq, jeq, i, j, m, n, ioff, joff
943 ioff = hio%idg_offset - hii%idg_offset
944 joff = hio%jdg_offset - hii%jdg_offset
948 isq = hio%IscB + ioff ; ieq = hio%IecB + ioff
949 jsq = hio%JscB + joff ; jeq = hio%JecB + joff
950 is = hio%isc + ioff ; ie = hio%iec + ioff
951 js = hio%jsc + joff ; je = hio%jec + joff
956 do_massweight = .false.
957 if (
present(usemasswghtinterp))
then ;
if (usemasswghtinterp)
then
958 do_massweight = .true.
959 if (.not.
present(bathyt))
call mom_error(fatal,
"int_density_dz_generic: "//&
960 "bathyT must be present if useMassWghtInterp is present and true.")
961 if (.not.
present(dz_neglect))
call mom_error(fatal,
"int_density_dz_generic: "//&
962 "dz_neglect must be present if useMassWghtInterp is present and true.")
965 do j=jsq,jeq+1 ;
do i=isq,ieq+1
966 dz = z_t(i,j) - z_b(i,j)
968 t5(n) = t(i,j) ; s5(n) = s(i,j)
969 p5(n) = -gxrho*(z_t(i,j) - 0.25*real(n-1)*dz)
974 rho_anom = c1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))
975 dpa(i-ioff,j-joff) = g_e*dz*rho_anom
978 if (
present(intz_dpa)) intz_dpa(i-ioff,j-joff) = 0.5*g_e*dz**2 * &
979 (rho_anom - c1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) )
982 if (
present(intx_dpa))
then ;
do j=js,je ;
do i=isq,ieq
988 hwght = max(0., -bathyt(i,j)-z_t(i+1,j), -bathyt(i+1,j)-z_t(i,j))
990 hl = (z_t(i,j) - z_b(i,j)) + dz_neglect
991 hr = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect
992 hwght = hwght * ( (hl-hr)/(hl+hr) )**2
993 idenom = 1.0 / ( hwght*(hr + hl) + hl*hr )
994 hwt_ll = (hwght*hl + hr*hl) * idenom ; hwt_lr = (hwght*hr) * idenom
995 hwt_rr = (hwght*hr + hr*hl) * idenom ; hwt_rl = (hwght*hl) * idenom
997 hwt_ll = 1.0 ; hwt_lr = 0.0 ; hwt_rr = 1.0 ; hwt_rl = 0.0
1000 intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff)
1004 wt_l = 0.25*real(5-m) ; wt_r = 1.0-wt_l
1005 wtt_l = wt_l*hwt_ll + wt_r*hwt_rl ; wtt_r = wt_l*hwt_lr + wt_r*hwt_rr
1006 dz = wt_l*(z_t(i,j) - z_b(i,j)) + wt_r*(z_t(i+1,j) - z_b(i+1,j))
1007 t5(1) = wtt_l*t(i,j) + wtt_r*t(i+1,j)
1008 s5(1) = wtt_l*s(i,j) + wtt_r*s(i+1,j)
1009 p5(1) = -gxrho*(wt_l*z_t(i,j) + wt_r*z_t(i+1,j))
1011 t5(n) = t5(1) ; s5(n) = s5(1) ; p5(n) = p5(n-1) + gxrho*0.25*dz
1016 intz(m) = g_e*dz*( c1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)))
1019 intx_dpa(i-ioff,j-joff) = c1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + &
1021 enddo ;
enddo ;
endif
1023 if (
present(inty_dpa))
then ;
do j=jsq,jeq ;
do i=is,ie
1028 if (do_massweight) &
1029 hwght = max(0., -bathyt(i,j)-z_t(i,j+1), -bathyt(i,j+1)-z_t(i,j))
1030 if (hwght > 0.)
then
1031 hl = (z_t(i,j) - z_b(i,j)) + dz_neglect
1032 hr = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect
1033 hwght = hwght * ( (hl-hr)/(hl+hr) )**2
1034 idenom = 1.0 / ( hwght*(hr + hl) + hl*hr )
1035 hwt_ll = (hwght*hl + hr*hl) * idenom ; hwt_lr = (hwght*hr) * idenom
1036 hwt_rr = (hwght*hr + hr*hl) * idenom ; hwt_rl = (hwght*hl) * idenom
1038 hwt_ll = 1.0 ; hwt_lr = 0.0 ; hwt_rr = 1.0 ; hwt_rl = 0.0
1041 intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i-ioff,j-joff+1)
1045 wt_l = 0.25*real(5-m) ; wt_r = 1.0-wt_l
1046 wtt_l = wt_l*hwt_ll + wt_r*hwt_rl ; wtt_r = wt_l*hwt_lr + wt_r*hwt_rr
1047 dz = wt_l*(z_t(i,j) - z_b(i,j)) + wt_r*(z_t(i,j+1) - z_b(i,j+1))
1048 t5(1) = wtt_l*t(i,j) + wtt_r*t(i,j+1)
1049 s5(1) = wtt_l*s(i,j) + wtt_r*s(i,j+1)
1050 p5(1) = -gxrho*(wt_l*z_t(i,j) + wt_r*z_t(i,j+1))
1052 t5(n) = t5(1) ; s5(n) = s5(1)
1053 p5(n) = p5(n-1) + gxrho*0.25*dz
1058 intz(m) = g_e*dz*( c1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)))
1061 inty_dpa(i-ioff,j-joff) = c1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + &
1063 enddo ;
enddo ;
endif
1064 end subroutine int_density_dz_generic
1070 subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, &
1071 rho_0, G_e, dz_subroundoff, bathyT, HII, HIO, EOS, dpa, &
1072 intz_dpa, intx_dpa, inty_dpa, &
1076 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1078 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1080 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1082 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1084 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1087 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1089 real,
intent(in) :: rho_ref
1091 real,
intent(in) :: rho_0
1093 real,
intent(in) :: g_e
1094 real,
intent(in) :: dz_subroundoff
1095 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1096 intent(in) :: bathyt
1098 real,
dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), &
1100 real,
dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), &
1101 optional,
intent(out) :: intz_dpa
1104 real,
dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), &
1105 optional,
intent(out) :: intx_dpa
1108 real,
dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), &
1109 optional,
intent(out) :: inty_dpa
1112 logical,
optional,
intent(in) :: usemasswghtinterp
1126 real :: t5((5*hio%iscb+1):(5*(hio%iecb+2)))
1127 real :: s5((5*hio%iscb+1):(5*(hio%iecb+2)))
1128 real :: p5((5*hio%iscb+1):(5*(hio%iecb+2)))
1129 real :: r5((5*hio%iscb+1):(5*(hio%iecb+2)))
1130 real :: t15((15*hio%iscb+1):(15*(hio%iecb+1)))
1131 real :: s15((15*hio%iscb+1):(15*(hio%iecb+1)))
1132 real :: p15((15*hio%iscb+1):(15*(hio%iecb+1)))
1133 real :: r15((15*hio%iscb+1):(15*(hio%iecb+1)))
1134 real :: wt_t(5), wt_b(5)
1136 real :: w_left, w_right
1139 real,
parameter :: c1_90 = 1.0/90.0
1142 real :: dz(hio%iscb:hio%iecb+1)
1143 real :: dz_x(5,hio%iscb:hio%iecb)
1144 real :: dz_y(5,hio%isc:hio%iec)
1145 real :: weight_t, weight_b
1146 real :: massweighttoggle
1147 real :: ttl, tbl, ttr, tbr
1148 real :: stl, sbl, str, sbr
1152 integer :: isq, ieq, jsq, jeq, i, j, m, n
1153 integer :: iin, jin, ioff, joff
1156 ioff = hio%idg_offset - hii%idg_offset
1157 joff = hio%jdg_offset - hii%jdg_offset
1159 isq = hio%IscB ; ieq = hio%IecB ; jsq = hio%JscB ; jeq = hio%JecB
1163 massweighttoggle = 0.
1164 if (
present(usemasswghtinterp))
then
1165 if (usemasswghtinterp) massweighttoggle = 1.
1169 wt_t(n) = 0.25 * real(5-n)
1170 wt_b(n) = 1.0 - wt_t(n)
1178 do i = isq,ieq+1 ; iin = i+ioff
1179 dz(i) = z_t(iin,jin) - z_b(iin,jin)
1181 p5(i*5+n) = -gxrho*(z_t(iin,jin) - 0.25*real(n-1)*dz(i))
1183 s5(i*5+n) = wt_t(n) * s_t(iin,jin) + wt_b(n) * s_b(iin,jin)
1184 t5(i*5+n) = wt_t(n) * t_t(iin,jin) + wt_b(n) * t_b(iin,jin)
1187 call calculate_density_array(t5, s5, p5, r5, 1, (ieq-isq+2)*5, eos, rho_ref )
1189 do i=isq,ieq+1 ; iin = i+ioff
1191 rho_anom = c1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3))
1192 dpa(i,j) = g_e*dz(i)*rho_anom
1193 if (
present(intz_dpa))
then
1196 intz_dpa(i,j) = 0.5*g_e*dz(i)**2 * &
1197 (rho_anom - c1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) )
1206 if (
present(intx_dpa))
then ;
do j=hio%jsc,hio%jec ; jin = j+joff
1207 do i=isq,ieq ; iin = i+ioff
1215 hwght = massweighttoggle * &
1216 max(0., -bathyt(iin,jin)-z_t(iin+1,jin), -bathyt(iin+1,jin)-z_t(iin,jin))
1217 if (hwght > 0.)
then
1218 hl = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff
1219 hr = (z_t(iin+1,jin) - z_b(iin+1,jin)) + dz_subroundoff
1220 hwght = hwght * ( (hl-hr)/(hl+hr) )**2
1221 idenom = 1./( hwght*(hr + hl) + hl*hr )
1222 ttl = ( (hwght*hr)*t_t(iin+1,jin) + (hwght*hl + hr*hl)*t_t(iin,jin) ) * idenom
1223 ttr = ( (hwght*hl)*t_t(iin,jin) + (hwght*hr + hr*hl)*t_t(iin+1,jin) ) * idenom
1224 tbl = ( (hwght*hr)*t_b(iin+1,jin) + (hwght*hl + hr*hl)*t_b(iin,jin) ) * idenom
1225 tbr = ( (hwght*hl)*t_b(iin,jin) + (hwght*hr + hr*hl)*t_b(iin+1,jin) ) * idenom
1226 stl = ( (hwght*hr)*s_t(iin+1,jin) + (hwght*hl + hr*hl)*s_t(iin,jin) ) * idenom
1227 str = ( (hwght*hl)*s_t(iin,jin) + (hwght*hr + hr*hl)*s_t(iin+1,jin) ) * idenom
1228 sbl = ( (hwght*hr)*s_b(iin+1,jin) + (hwght*hl + hr*hl)*s_b(iin,jin) ) * idenom
1229 sbr = ( (hwght*hl)*s_b(iin,jin) + (hwght*hr + hr*hl)*s_b(iin+1,jin) ) * idenom
1231 ttl = t_t(iin,jin); tbl = t_b(iin,jin); ttr = t_t(iin+1,jin); tbr = t_b(iin+1,jin)
1232 stl = s_t(iin,jin); sbl = s_b(iin,jin); str = s_t(iin+1,jin); sbr = s_b(iin+1,jin)
1236 w_left = 0.25*real(5-m) ; w_right = 1.0-w_left
1237 dz_x(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin+1,jin) - z_b(iin+1,jin))
1244 t15(pos+1) = w_left*ttl + w_right*ttr
1245 t15(pos+5) = w_left*tbl + w_right*tbr
1247 s15(pos+1) = w_left*stl + w_right*str
1248 s15(pos+5) = w_left*sbl + w_right*sbr
1250 p15(pos+1) = -gxrho*(w_left*z_t(iin,jin) + w_right*z_t(iin+1,jin))
1254 p15(pos+n) = p15(pos+n-1) + gxrho*0.25*dz_x(m,i)
1259 weight_t = 0.25 * real(5-n)
1260 weight_b = 1.0 - weight_t
1261 s15(pos+n) = weight_t * s15(pos+1) + weight_b * s15(pos+5)
1262 t15(pos+n) = weight_t * t15(pos+1) + weight_b * t15(pos+5)
1269 do i=isq,ieq ; iin = i+ioff
1270 intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j)
1275 intz(m) = g_e*dz_x(m,i)*( c1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + &
1279 intx_dpa(i,j) = c1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + &
1287 if (
present(inty_dpa))
then ;
do j=jsq,jeq ; jin = j+joff
1288 do i=hio%isc,hio%iec ; iin = i+ioff
1296 hwght = massweighttoggle * &
1297 max(0., -bathyt(i,j)-z_t(iin,jin+1), -bathyt(i,j+1)-z_t(iin,jin))
1298 if (hwght > 0.)
then
1299 hl = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff
1300 hr = (z_t(iin,jin+1) - z_b(iin,jin+1)) + dz_subroundoff
1301 hwght = hwght * ( (hl-hr)/(hl+hr) )**2
1302 idenom = 1./( hwght*(hr + hl) + hl*hr )
1303 ttl = ( (hwght*hr)*t_t(iin,jin+1) + (hwght*hl + hr*hl)*t_t(iin,jin) ) * idenom
1304 ttr = ( (hwght*hl)*t_t(iin,jin) + (hwght*hr + hr*hl)*t_t(iin,jin+1) ) * idenom
1305 tbl = ( (hwght*hr)*t_b(iin,jin+1) + (hwght*hl + hr*hl)*t_b(iin,jin) ) * idenom
1306 tbr = ( (hwght*hl)*t_b(iin,jin) + (hwght*hr + hr*hl)*t_b(iin,jin+1) ) * idenom
1307 stl = ( (hwght*hr)*s_t(iin,jin+1) + (hwght*hl + hr*hl)*s_t(iin,jin) ) * idenom
1308 str = ( (hwght*hl)*s_t(iin,jin) + (hwght*hr + hr*hl)*s_t(iin,jin+1) ) * idenom
1309 sbl = ( (hwght*hr)*s_b(iin,jin+1) + (hwght*hl + hr*hl)*s_b(iin,jin) ) * idenom
1310 sbr = ( (hwght*hl)*s_b(iin,jin) + (hwght*hr + hr*hl)*s_b(iin,jin+1) ) * idenom
1312 ttl = t_t(iin,jin); tbl = t_b(iin,jin); ttr = t_t(iin,jin+1); tbr = t_b(iin,jin+1)
1313 stl = s_t(iin,jin); sbl = s_b(iin,jin); str = s_t(iin,jin+1); sbr = s_b(iin,jin+1)
1317 w_left = 0.25*real(5-m) ; w_right = 1.0-w_left
1318 dz_y(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin,jin+1) - z_b(iin,jin+1))
1325 t15(pos+1) = w_left*ttl + w_right*ttr
1326 t15(pos+5) = w_left*tbl + w_right*tbr
1328 s15(pos+1) = w_left*stl + w_right*str
1329 s15(pos+5) = w_left*sbl + w_right*sbr
1331 p15(pos+1) = -gxrho*(w_left*z_t(iin,jin) + w_right*z_t(iin,jin+1))
1334 do n=2,5 ; p15(pos+n) = p15(pos+n-1) + gxrho*0.25*dz_y(m,i) ;
enddo
1338 weight_t = 0.25 * real(5-n)
1339 weight_b = 1.0 - weight_t
1340 s15(pos+n) = weight_t * s15(pos+1) + weight_b * s15(pos+5)
1341 t15(pos+n) = weight_t * t15(pos+1) + weight_b * t15(pos+5)
1346 call calculate_density_array(t15(15*hio%isc+1:), s15(15*hio%isc+1:), p15(15*hio%isc+1:), &
1347 r15(15*hio%isc+1:), 1, 15*(hio%iec-hio%isc+1), eos, rho_ref)
1348 do i=hio%isc,hio%iec ; iin = i+ioff
1349 intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1)
1354 intz(m) = g_e*dz_y(m,i)*( c1_90*(7.0*(r15(pos+1)+r15(pos+5)) + &
1355 32.0*(r15(pos+2)+r15(pos+4)) + &
1359 inty_dpa(i,j) = c1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + &
1364 end subroutine int_density_dz_generic_plm
1371 subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, &
1372 rho_ref, G_e, EOS, P_b, z_out, z_tol)
1373 real,
intent(in) :: t_t
1374 real,
intent(in) :: t_b
1375 real,
intent(in) :: s_t
1376 real,
intent(in) :: s_b
1377 real,
intent(in) :: z_t
1378 real,
intent(in) :: z_b
1379 real,
intent(in) :: p_t
1380 real,
intent(in) :: p_tgt
1381 real,
intent(in) :: rho_ref
1382 real,
intent(in) :: g_e
1384 real,
intent(out) :: p_b
1385 real,
intent(out) :: z_out
1386 real,
optional,
intent(in) :: z_tol
1388 real :: top_weight, bottom_weight, rho_anom, w_left, w_right, gxrho, dz, dp, f_guess, f_l, f_r
1389 real :: pa, pa_left, pa_right, pa_tol
1391 gxrho = g_e * rho_ref
1394 dp = frac_dp_at_pos(t_t, t_b, s_t, s_b, z_t, z_b, rho_ref, g_e, 1.0, eos)
1398 if (p_tgt <= p_t )
then
1403 if (p_tgt >= p_b)
then
1409 pa_left = p_t - p_tgt
1411 pa_right = p_b - p_tgt
1412 pa_tol = gxrho * 1.e-5
1413 if (
present(z_tol)) pa_tol = gxrho * z_tol
1414 f_guess = f_l - pa_left / ( pa_right -pa_left ) * ( f_r - f_l )
1415 pa = pa_right - pa_left
1416 do while ( abs(pa) > pa_tol )
1418 z_out = z_t + ( z_b - z_t ) * f_guess
1419 pa = frac_dp_at_pos(t_t, t_b, s_t, s_b, z_t, z_b, rho_ref, g_e, f_guess, eos) - ( p_tgt - p_t )
1421 if (pa<pa_left)
then
1422 write(0,*) pa_left,pa,pa_right,p_t-p_tgt,p_b-p_tgt
1423 stop
'Blurgh! Too negative'
1427 elseif (pa>pa_right)
then
1428 write(0,*) pa_left,pa,pa_right,p_t-p_tgt,p_b-p_tgt
1429 stop
'Blurgh! Too positive'
1436 f_guess = f_l - pa_left / ( pa_right -pa_left ) * ( f_r - f_l )
1440 end subroutine find_depth_of_pressure_in_cell
1444 real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS)
1445 real,
intent(in) :: t_t
1446 real,
intent(in) :: t_b
1447 real,
intent(in) :: s_t
1448 real,
intent(in) :: s_b
1449 real,
intent(in) :: z_t
1450 real,
intent(in) :: z_b
1451 real,
intent(in) :: rho_ref
1453 real,
intent(in) :: g_e
1454 real,
intent(in) :: pos
1457 real,
parameter :: c1_90 = 1.0/90.0
1458 real :: dz, top_weight, bottom_weight, rho_ave
1459 real,
dimension(5) :: t5, s5, p5, rho5
1464 bottom_weight = 0.25*real(n-1) * pos
1465 top_weight = 1.0 - bottom_weight
1467 s5(n) = top_weight * s_t + bottom_weight * s_b
1468 t5(n) = top_weight * t_t + bottom_weight * t_b
1469 p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( g_e * rho_ref )
1471 call calculate_density_array(t5, s5, p5, rho5, 1, 5, eos)
1475 rho_ave = c1_90*(7.0*(rho5(1)+rho5(5)) + 32.0*(rho5(2)+rho5(4)) + 12.0*rho5(3))
1477 dz = ( z_t - z_b ) * pos
1478 frac_dp_at_pos = g_e * dz * rho_ave
1479 end function frac_dp_at_pos
1485 subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, &
1486 z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, &
1487 EOS, dpa, intz_dpa, intx_dpa, inty_dpa)
1491 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1493 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1495 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1497 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1499 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1501 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1503 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1505 real,
dimension(HII%isd:HII%ied,HII%jsd:HII%jed), &
1507 real,
intent(in) :: rho_ref
1509 real,
intent(in) :: rho_0
1511 real,
intent(in) :: g_e
1513 real,
dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), &
1515 real,
dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), &
1516 optional,
intent(out) :: intz_dpa
1519 real,
dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), &
1520 optional,
intent(out) :: intx_dpa
1523 real,
dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), &
1524 optional,
intent(out) :: inty_dpa
1540 real :: t5(5), s5(5), p5(5), r5(5)
1542 real :: w_left, w_right, intz(5)
1543 real,
parameter :: c1_90 = 1.0/90.0
1544 real :: gxrho, i_rho
1546 real :: weight_t, weight_b
1550 real :: t_top, t_mid, t_bot
1551 real :: s_top, s_mid, s_bot
1552 integer :: is, ie, js, je, isq, ieq, jsq, jeq, i, j, m, n, ioff, joff
1553 real,
dimension(4) :: x, y
1554 real,
dimension(9) :: s_node, t_node, p_node, r_node
1557 call mom_error(fatal, &
1558 "int_density_dz_generic_ppm: the implementation is not done yet, contact developer")
1560 ioff = hio%idg_offset - hii%idg_offset
1561 joff = hio%jdg_offset - hii%jdg_offset
1565 isq = hio%IscB + ioff ; ieq = hio%IecB + ioff
1566 jsq = hio%JscB + joff ; jeq = hio%JecB + joff
1567 is = hio%isc + ioff ; ie = hio%iec + ioff
1568 js = hio%jsc + joff ; je = hio%jec + joff
1576 do j=jsq,jeq+1 ;
do i=isq,ieq+1
1577 dz = z_t(i,j) - z_b(i,j)
1581 s1 = 6.0 * s(i,j) - 4.0 * s_t(i,j) - 2.0 * s_b(i,j)
1582 s2 = 3.0 * ( s_t(i,j) + s_b(i,j) - 2.0*s(i,j) )
1586 t1 = 6.0 * t(i,j) - 4.0 * t_t(i,j) - 2.0 * t_b(i,j)
1587 t2 = 3.0 * ( t_t(i,j) + t_b(i,j) - 2.0*t(i,j) )
1590 p5(n) = -gxrho*(z_t(i,j) - 0.25*real(n-1)*dz)
1593 xi = 0.25 * ( n - 1 )
1594 s5(n) = s0 + s1 * xi + s2 * xi**2
1595 t5(n) = t0 + t1 * xi + t2 * xi**2
1604 rho_anom = 1000.0 + s(i,j) - rho_ref
1605 dpa(i-ioff,j-joff) = g_e*dz*rho_anom
1613 intz_dpa(i-ioff,j-joff) = 0.5 * g_e * dz**2 * ( 1000.0 - rho_ref + s0 + s1/3.0 + &
1620 if (
present(intx_dpa))
then ;
do j=js,je ;
do i=isq,ieq
1621 intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff)
1623 w_left = 0.25*real(5-m) ; w_right = 1.0-w_left
1624 dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j))
1630 t_top = w_left*t_t(i,j) + w_right*t_t(i+1,j)
1631 t_mid = w_left*t(i,j) + w_right*t(i+1,j)
1632 t_bot = w_left*t_b(i,j) + w_right*t_b(i+1,j)
1634 s_top = w_left*s_t(i,j) + w_right*s_t(i+1,j)
1635 s_mid = w_left*s(i,j) + w_right*s(i+1,j)
1636 s_bot = w_left*s_b(i,j) + w_right*s_b(i+1,j)
1638 p5(1) = -gxrho*(w_left*z_t(i,j) + w_right*z_t(i+1,j))
1642 p5(n) = p5(n-1) + gxrho*0.25*dz
1647 s1 = 6.0 * s_mid - 4.0 * s_top - 2.0 * s_bot
1648 s2 = 3.0 * ( s_top + s_bot - 2.0*s_mid )
1652 t1 = 6.0 * t_mid - 4.0 * t_top - 2.0 * t_bot
1653 t2 = 3.0 * ( t_top + t_bot - 2.0*t_mid )
1657 xi = 0.25 * ( n - 1 )
1658 s5(n) = s0 + s1 * xi + s2 * xi**2
1659 t5(n) = t0 + t1 * xi + t2 * xi**2
1665 intz(m) = g_e*dz*( c1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + &
1666 12.0*r5(3)) - rho_ref)
1668 intx_dpa(i-ioff,j-joff) = c1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + &
1691 s1 = 6.0 * s(i,j) - 4.0 * s_t(i,j) - 2.0 * s_b(i,j)
1692 s2 = 3.0 * ( s_t(i,j) + s_b(i,j) - 2.0 * s(i,j) )
1694 s_node(6) = s0 + 0.5 * s1 + 0.25 * s2
1695 s_node(3) = s0 + s1 + s2
1699 s1 = 6.0 * s(i+1,j) - 4.0 * s_t(i+1,j) - 2.0 * s_b(i+1,j)
1700 s2 = 3.0 * ( s_t(i+1,j) + s_b(i+1,j) - 2.0 * s(i+1,j) )
1702 s_node(8) = s0 + 0.5 * s1 + 0.25 * s2
1703 s_node(4) = s0 + s1 + s2
1705 s_node(5) = 0.5 * ( s_node(2) + s_node(1) )
1706 s_node(9) = 0.5 * ( s_node(6) + s_node(8) )
1707 s_node(7) = 0.5 * ( s_node(3) + s_node(4) )
1710 r_node = r_node - rho_ref
1712 call compute_integral_quadratic( x, y, r_node, intx_dpa(i-ioff,j-joff) )
1714 intx_dpa(i-ioff,j-joff) = intx_dpa(i-ioff,j-joff) * g_e
1716 enddo ;
enddo ;
endif
1721 if (
present(inty_dpa))
then
1722 call mom_error(warning,
"int_density_dz_generic_ppm still needs to be written for inty_dpa!")
1723 do j=jsq,jeq ;
do i=is,ie
1725 inty_dpa(i-ioff,j-joff) = 0.0
1730 end subroutine int_density_dz_generic_ppm
1736 subroutine compute_integral_quadratic( x, y, f, integral )
1737 real,
dimension(4),
intent(in) :: x
1738 real,
dimension(4),
intent(in) :: y
1739 real,
dimension(9),
intent(in) :: f
1740 real,
intent(out) :: integral
1744 real,
dimension(9) :: weight, xi, eta
1746 real :: dxdxi, dxdeta
1747 real :: dydxi, dydeta
1748 real,
dimension(4) :: phiiso, dphiisodxi, dphiisodeta
1749 real,
dimension(9) :: phi, dphidxi, dphideta
1766 weight(1) = 25.0/81.0 ; xi(1) = -t ; eta(1) = t
1767 weight(2) = 40.0/81.0 ; xi(2) = .0 ; eta(2) = t
1768 weight(3) = 25.0/81.0 ; xi(3) = t ; eta(3) = t
1769 weight(4) = 40.0/81.0 ; xi(4) = -t ; eta(4) = .0
1770 weight(5) = 64.0/81.0 ; xi(5) = .0 ; eta(5) = .0
1771 weight(6) = 40.0/81.0 ; xi(6) = t ; eta(6) = .0
1772 weight(7) = 25.0/81.0 ; xi(7) = -t ; eta(7) = -t
1773 weight(8) = 40.0/81.0 ; xi(8) = .0 ; eta(8) = -t
1774 weight(9) = 25.0/81.0 ; xi(9) = t ; eta(9) = -t
1782 call evaluate_shape_bilinear( xi(k), eta(k), phiiso, &
1783 dphiisodxi, dphiisodeta )
1792 dxdxi = dxdxi + x(i) * dphiisodxi(i)
1793 dxdeta = dxdeta + x(i) * dphiisodeta(i)
1794 dydxi = dydxi + y(i) * dphiisodxi(i)
1795 dydeta = dydeta + y(i) * dphiisodeta(i)
1799 jacobian_k = dxdxi*dydeta - dydxi*dxdeta
1802 call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta )
1807 f_k = f_k + f(i) * phi(i)
1810 integral = integral + weight(k) * f_k * jacobian_k
1814 end subroutine compute_integral_quadratic
1819 subroutine evaluate_shape_bilinear( xi, eta, phi, dphidxi, dphideta )
1820 real,
intent(in) :: xi
1821 real,
intent(in) :: eta
1822 real,
dimension(4),
intent(out) :: phi
1823 real,
dimension(4),
intent(out) :: dphidxi
1825 real,
dimension(4),
intent(out) :: dphideta
1838 phi(1) = 0.25 * ( 1 + xi ) * ( 1 + eta )
1839 phi(2) = 0.25 * ( 1 - xi ) * ( 1 + eta )
1840 phi(3) = 0.25 * ( 1 - xi ) * ( 1 - eta )
1841 phi(4) = 0.25 * ( 1 + xi ) * ( 1 - eta )
1843 dphidxi(1) = 0.25 * ( 1 + eta )
1844 dphidxi(2) = - 0.25 * ( 1 + eta )
1845 dphidxi(3) = - 0.25 * ( 1 - eta )
1846 dphidxi(4) = 0.25 * ( 1 - eta )
1848 dphideta(1) = 0.25 * ( 1 + xi )
1849 dphideta(2) = 0.25 * ( 1 - xi )
1850 dphideta(3) = - 0.25 * ( 1 - xi )
1851 dphideta(4) = - 0.25 * ( 1 + xi )
1853 end subroutine evaluate_shape_bilinear
1858 subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta )
1861 real,
intent(in) :: xi
1862 real,
intent(in) :: eta
1863 real,
dimension(9),
intent(out) :: phi
1865 real,
dimension(9),
intent(out) :: dphidxi
1867 real,
dimension(9),
intent(out) :: dphideta
1887 phi(1) = 0.25 * xi * ( 1 + xi ) * eta * ( 1 + eta )
1888 phi(2) = - 0.25 * xi * ( 1 - xi ) * eta * ( 1 + eta )
1889 phi(3) = 0.25 * xi * ( 1 - xi ) * eta * ( 1 - eta )
1890 phi(4) = - 0.25 * xi * ( 1 + xi ) * eta * ( 1 - eta )
1891 phi(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * eta * ( 1 + eta )
1892 phi(6) = - 0.5 * xi * ( 1 - xi ) * ( 1 - eta ) * ( 1 + eta )
1893 phi(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * eta * ( 1 - eta )
1894 phi(8) = 0.5 * xi * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta )
1895 phi(9) = ( 1 - xi ) * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta )
1917 end subroutine evaluate_shape_quadratic
1924 subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, &
1925 dza, intp_dza, intx_dza, inty_dza, halo_size, &
1926 bathyP, dP_neglect, useMassWghtInterp)
1928 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
1930 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
1932 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
1934 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
1936 real,
intent(in) :: alpha_ref
1942 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
1945 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
1946 optional,
intent(out) :: intp_dza
1949 real,
dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), &
1950 optional,
intent(out) :: intx_dza
1953 real,
dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), &
1954 optional,
intent(out) :: inty_dza
1957 integer,
optional,
intent(in) :: halo_size
1958 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
1959 optional,
intent(in) :: bathyp
1960 real,
optional,
intent(in) :: dp_neglect
1962 logical,
optional,
intent(in) :: usemasswghtinterp
1972 real :: t5(5), s5(5), p5(5), a5(5)
1979 real :: hwt_ll, hwt_lr
1980 real :: hwt_rl, hwt_rr
1982 real :: wtt_l, wtt_r
1985 logical :: do_massweight
1986 real,
parameter :: c1_90 = 1.0/90.0
1987 integer :: isq, ieq, jsq, jeq, ish, ieh, jsh, jeh, i, j, m, n, halo
1989 isq = hi%IscB ; ieq = hi%IecB ; jsq = hi%JscB ; jeq = hi%JecB
1990 halo = 0 ;
if (
present(halo_size)) halo = max(halo_size,0)
1991 ish = hi%isc-halo ; ieh = hi%iec+halo ; jsh = hi%jsc-halo ; jeh = hi%jec+halo
1992 if (
present(intx_dza))
then ; ish = min(isq,ish) ; ieh = max(ieq+1,ieh);
endif
1993 if (
present(inty_dza))
then ; jsh = min(jsq,jsh) ; jeh = max(jeq+1,jeh);
endif
1995 do_massweight = .false.
1996 if (
present(usemasswghtinterp))
then ;
if (usemasswghtinterp)
then
1997 do_massweight = .true.
1998 if (.not.
present(bathyp))
call mom_error(fatal,
"int_spec_vol_dp_generic: "//&
1999 "bathyP must be present if useMassWghtInterp is present and true.")
2000 if (.not.
present(dp_neglect))
call mom_error(fatal,
"int_spec_vol_dp_generic: "//&
2001 "dP_neglect must be present if useMassWghtInterp is present and true.")
2004 do j=jsh,jeh ;
do i=ish,ieh
2005 dp = p_b(i,j) - p_t(i,j)
2007 t5(n) = t(i,j) ; s5(n) = s(i,j)
2008 p5(n) = p_b(i,j) - 0.25*real(n-1)*dp
2013 alpha_anom = c1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3))
2014 dza(i,j) = dp*alpha_anom
2017 if (
present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * &
2018 (alpha_anom - c1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) )
2021 if (
present(intx_dza))
then ;
do j=hi%jsc,hi%jec ;
do i=isq,ieq
2026 if (do_massweight) &
2027 hwght = max(0., bathyp(i,j)-p_t(i+1,j), bathyp(i+1,j)-p_t(i,j))
2028 if (hwght > 0.)
then
2029 hl = (p_b(i,j) - p_t(i,j)) + dp_neglect
2030 hr = (p_b(i+1,j) - p_t(i+1,j)) + dp_neglect
2031 hwght = hwght * ( (hl-hr)/(hl+hr) )**2
2032 idenom = 1.0 / ( hwght*(hr + hl) + hl*hr )
2033 hwt_ll = (hwght*hl + hr*hl) * idenom ; hwt_lr = (hwght*hr) * idenom
2034 hwt_rr = (hwght*hr + hr*hl) * idenom ; hwt_rl = (hwght*hl) * idenom
2036 hwt_ll = 1.0 ; hwt_lr = 0.0 ; hwt_rr = 1.0 ; hwt_rl = 0.0
2039 intp(1) = dza(i,j) ; intp(5) = dza(i+1,j)
2041 wt_l = 0.25*real(5-m) ; wt_r = 1.0-wt_l
2042 wtt_l = wt_l*hwt_ll + wt_r*hwt_rl ; wtt_r = wt_l*hwt_lr + wt_r*hwt_rr
2046 p5(1) = wt_l*p_b(i,j) + wt_r*p_b(i+1,j)
2047 dp = wt_l*(p_b(i,j) - p_t(i,j)) + wt_r*(p_b(i+1,j) - p_t(i+1,j))
2048 t5(1) = wtt_l*t(i,j) + wtt_r*t(i+1,j)
2049 s5(1) = wtt_l*s(i,j) + wtt_r*s(i+1,j)
2052 t5(n) = t5(1) ; s5(n) = s5(1) ; p5(n) = p5(n-1) - 0.25*dp
2057 intp(m) = dp*( c1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + &
2061 intx_dza(i,j) = c1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + &
2063 enddo ;
enddo ;
endif
2065 if (
present(inty_dza))
then ;
do j=jsq,jeq ;
do i=hi%isc,hi%iec
2070 if (do_massweight) &
2071 hwght = max(0., bathyp(i,j)-p_t(i,j+1), bathyp(i,j+1)-p_t(i,j))
2072 if (hwght > 0.)
then
2073 hl = (p_b(i,j) - p_t(i,j)) + dp_neglect
2074 hr = (p_b(i,j+1) - p_t(i,j+1)) + dp_neglect
2075 hwght = hwght * ( (hl-hr)/(hl+hr) )**2
2076 idenom = 1.0 / ( hwght*(hr + hl) + hl*hr )
2077 hwt_ll = (hwght*hl + hr*hl) * idenom ; hwt_lr = (hwght*hr) * idenom
2078 hwt_rr = (hwght*hr + hr*hl) * idenom ; hwt_rl = (hwght*hl) * idenom
2080 hwt_ll = 1.0 ; hwt_lr = 0.0 ; hwt_rr = 1.0 ; hwt_rl = 0.0
2083 intp(1) = dza(i,j) ; intp(5) = dza(i,j+1)
2085 wt_l = 0.25*real(5-m) ; wt_r = 1.0-wt_l
2086 wtt_l = wt_l*hwt_ll + wt_r*hwt_rl ; wtt_r = wt_l*hwt_lr + wt_r*hwt_rr
2090 p5(1) = wt_l*p_b(i,j) + wt_r*p_b(i,j+1)
2091 dp = wt_l*(p_b(i,j) - p_t(i,j)) + wt_r*(p_b(i,j+1) - p_t(i,j+1))
2092 t5(1) = wtt_l*t(i,j) + wtt_r*t(i,j+1)
2093 s5(1) = wtt_l*s(i,j) + wtt_r*s(i,j+1)
2095 t5(n) = t5(1) ; s5(n) = s5(1) ; p5(n) = p5(n-1) - 0.25*dp
2100 intp(m) = dp*( c1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + &
2104 inty_dza(i,j) = c1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + &
2106 enddo ;
enddo ;
endif
2108 end subroutine int_spec_vol_dp_generic
2114 subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, &
2115 dP_neglect, bathyP, HI, EOS, dza, &
2116 intp_dza, intx_dza, inty_dza, useMassWghtInterp)
2118 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
2120 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
2122 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
2124 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
2126 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
2128 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
2130 real,
intent(in) :: alpha_ref
2135 real,
intent(in) :: dp_neglect
2137 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
2138 intent(in) :: bathyp
2140 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
2143 real,
dimension(HI%isd:HI%ied,HI%jsd:HI%jed), &
2144 optional,
intent(out) :: intp_dza
2147 real,
dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), &
2148 optional,
intent(out) :: intx_dza
2151 real,
dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), &
2152 optional,
intent(out) :: inty_dza
2155 logical,
optional,
intent(in) :: usemasswghtinterp
2165 real,
dimension(5) :: t5, s5, p5, a5
2166 real,
dimension(15) :: t15, s15, p15, a15
2167 real :: wt_t(5), wt_b(5)
2168 real :: t_top, t_bot, s_top, s_bot, p_top, p_bot
2176 real :: hwt_ll, hwt_lr
2177 real :: hwt_rl, hwt_rr
2179 real :: wtt_l, wtt_r
2182 real,
parameter :: c1_90 = 1.0/90.0
2183 logical :: do_massweight
2184 integer :: isq, ieq, jsq, jeq, i, j, m, n, pos
2186 isq = hi%IscB ; ieq = hi%IecB ; jsq = hi%JscB ; jeq = hi%JecB
2188 do_massweight = .false.
2189 if (
present(usemasswghtinterp)) do_massweight = usemasswghtinterp
2192 wt_t(n) = 0.25 * real(n-1)
2193 wt_b(n) = 1.0 - wt_t(n)
2199 do j=jsq,jeq+1;
do i=isq,ieq+1
2200 dp = p_b(i,j) - p_t(i,j)
2202 p5(n) = wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j)
2203 s5(n) = wt_t(n) * s_t(i,j) + wt_b(n) * s_b(i,j)
2204 t5(n) = wt_t(n) * t_t(i,j) + wt_b(n) * t_b(i,j)
2209 alpha_anom = c1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3))
2210 dza(i,j) = dp*alpha_anom
2213 if (
present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * &
2214 (alpha_anom - c1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) )
2220 if (
present(intx_dza))
then ;
do j=hi%jsc,hi%jec ;
do i=isq,ieq
2227 if (do_massweight) &
2228 hwght = max(0., bathyp(i,j)-p_t(i+1,j), bathyp(i+1,j)-p_t(i,j))
2229 if (hwght > 0.)
then
2230 hl = (p_b(i,j) - p_t(i,j)) + dp_neglect
2231 hr = (p_b(i+1,j) - p_t(i+1,j)) + dp_neglect
2232 hwght = hwght * ( (hl-hr)/(hl+hr) )**2
2233 idenom = 1.0 / ( hwght*(hr + hl) + hl*hr )
2234 hwt_ll = (hwght*hl + hr*hl) * idenom ; hwt_lr = (hwght*hr) * idenom
2235 hwt_rr = (hwght*hr + hr*hl) * idenom ; hwt_rl = (hwght*hl) * idenom
2237 hwt_ll = 1.0 ; hwt_lr = 0.0 ; hwt_rr = 1.0 ; hwt_rl = 0.0
2241 wt_l = 0.25*real(5-m) ; wt_r = 1.0-wt_l
2242 wtt_l = wt_l*hwt_ll + wt_r*hwt_rl ; wtt_r = wt_l*hwt_lr + wt_r*hwt_rr
2246 p_top = wt_l*p_t(i,j) + wt_r*p_t(i+1,j)
2247 p_bot = wt_l*p_b(i,j) + wt_r*p_b(i+1,j)
2248 t_top = wtt_l*t_t(i,j) + wtt_r*t_t(i+1,j)
2249 t_bot = wtt_l*t_b(i,j) + wtt_r*t_b(i+1,j)
2250 s_top = wtt_l*s_t(i,j) + wtt_r*s_t(i+1,j)
2251 s_bot = wtt_l*s_b(i,j) + wtt_r*s_b(i+1,j)
2252 dp_90(m) = c1_90*(p_bot - p_top)
2257 p15(pos+n) = wt_t(n) * p_top + wt_b(n) * p_bot
2258 s15(pos+n) = wt_t(n) * s_top + wt_b(n) * s_bot
2259 t15(pos+n) = wt_t(n) * t_top + wt_b(n) * t_bot
2265 intp(1) = dza(i,j) ; intp(5) = dza(i+1,j)
2270 intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + &
2271 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3))
2274 intx_dza(i,j) = c1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + &
2276 enddo ;
enddo ;
endif
2281 if (
present(inty_dza))
then ;
do j=jsq,jeq ;
do i=hi%isc,hi%iec
2286 if (do_massweight) &
2287 hwght = max(0., bathyp(i,j)-p_t(i,j+1), bathyp(i,j+1)-p_t(i,j))
2288 if (hwght > 0.)
then
2289 hl = (p_b(i,j) - p_t(i,j)) + dp_neglect
2290 hr = (p_b(i,j+1) - p_t(i,j+1)) + dp_neglect
2291 hwght = hwght * ( (hl-hr)/(hl+hr) )**2
2292 idenom = 1.0 / ( hwght*(hr + hl) + hl*hr )
2293 hwt_ll = (hwght*hl + hr*hl) * idenom ; hwt_lr = (hwght*hr) * idenom
2294 hwt_rr = (hwght*hr + hr*hl) * idenom ; hwt_rl = (hwght*hl) * idenom
2296 hwt_ll = 1.0 ; hwt_lr = 0.0 ; hwt_rr = 1.0 ; hwt_rl = 0.0
2300 wt_l = 0.25*real(5-m) ; wt_r = 1.0-wt_l
2301 wtt_l = wt_l*hwt_ll + wt_r*hwt_rl ; wtt_r = wt_l*hwt_lr + wt_r*hwt_rr
2305 p_top = wt_l*p_t(i,j) + wt_r*p_t(i,j+1)
2306 p_bot = wt_l*p_b(i,j) + wt_r*p_b(i,j+1)
2307 t_top = wtt_l*t_t(i,j) + wtt_r*t_t(i,j+1)
2308 t_bot = wtt_l*t_b(i,j) + wtt_r*t_b(i,j+1)
2309 s_top = wtt_l*s_t(i,j) + wtt_r*s_t(i,j+1)
2310 s_bot = wtt_l*s_b(i,j) + wtt_r*s_b(i,j+1)
2311 dp_90(m) = c1_90*(p_bot - p_top)
2316 p15(pos+n) = wt_t(n) * p_top + wt_b(n) * p_bot
2317 s15(pos+n) = wt_t(n) * s_top + wt_b(n) * s_bot
2318 t15(pos+n) = wt_t(n) * t_top + wt_b(n) * t_bot
2324 intp(1) = dza(i,j) ; intp(5) = dza(i,j+1)
2329 intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + &
2330 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3))
2333 inty_dza(i,j) = c1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + &
2335 enddo ;
enddo ;
endif
2337 end subroutine int_spec_vol_dp_generic_plm
2340 subroutine convert_temp_salt_for_teos10(T, S, press, G, kd, mask_z, EOS)
2344 real,
dimension(SZI_(G),SZJ_(G), SZK_(G)), &
2346 real,
dimension(SZI_(G),SZJ_(G), SZK_(G)), &
2348 real,
dimension(:),
intent(in) :: press
2350 real,
dimension(SZI_(G),SZJ_(G), SZK_(G)), &
2351 intent(in) :: mask_z
2352 integer,
intent(in) :: kd
2355 real :: gsw_sr_from_sp, gsw_ct_from_pt, gsw_sa_from_sp
2358 if (.not.
associated(eos))
call mom_error(fatal, &
2359 "convert_temp_salt_to_TEOS10 called with an unassociated EOS_type EOS.")
2361 if ((eos%form_of_EOS /= eos_teos10) .and. (eos%form_of_EOS /= eos_nemo))
return
2363 do k=1,kd ;
do j=g%jsc,g%jec ;
do i=g%isc,g%iec
2364 if (mask_z(i,j,k) >= 1.0)
then
2365 s(i,j,k) = gsw_sr_from_sp(s(i,j,k))
2368 t(i,j,k) = gsw_ct_from_pt(s(i,j,k),t(i,j,k))
2370 enddo ;
enddo ;
enddo
2371 end subroutine convert_temp_salt_for_teos10
2374 subroutine extract_member_eos(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, &
2375 Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp)
2377 integer,
optional,
intent(out) :: form_of_eos
2378 integer,
optional,
intent(out) :: form_of_tfreeze
2380 logical,
optional,
intent(out) :: eos_quadrature
2382 logical,
optional,
intent(out) :: compressible
2383 real ,
optional,
intent(out) :: rho_t0_s0
2384 real ,
optional,
intent(out) :: drho_dt
2386 real ,
optional,
intent(out) :: drho_ds
2388 real ,
optional,
intent(out) :: tfr_s0_p0
2389 real ,
optional,
intent(out) :: dtfr_ds
2391 real ,
optional,
intent(out) :: dtfr_dp
2394 if (
present(form_of_eos )) form_of_eos = eos%form_of_EOS
2395 if (
present(form_of_tfreeze)) form_of_tfreeze = eos%form_of_TFreeze
2396 if (
present(eos_quadrature )) eos_quadrature = eos%EOS_quadrature
2397 if (
present(compressible )) compressible = eos%Compressible
2398 if (
present(rho_t0_s0 )) rho_t0_s0 = eos%Rho_T0_S0
2399 if (
present(drho_dt )) drho_dt = eos%drho_dT
2400 if (
present(drho_ds )) drho_ds = eos%dRho_dS
2401 if (
present(tfr_s0_p0 )) tfr_s0_p0 = eos%TFr_S0_P0
2402 if (
present(dtfr_ds )) dtfr_ds = eos%dTFr_dS
2403 if (
present(dtfr_dp )) dtfr_dp = eos%dTFr_dp
2405 end subroutine extract_member_eos