-
Notifications
You must be signed in to change notification settings - Fork 1
/
domhgr.f90
129 lines (129 loc) · 6.04 KB
/
domhgr.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
MODULE domhgr
USE dom_oce
USE par_oce
USE phycst
USE usrdef_hgr
USE in_out_manager
USE iom
USE lib_mpp
USE timing
IMPLICIT NONE
PRIVATE
PUBLIC :: dom_hgr
CONTAINS
SUBROUTINE dom_hgr
INTEGER :: ji, jj
INTEGER :: ie1e2u_v
INTEGER :: iff
IF (ln_timing) CALL timing_start('dom_hgr')
IF (lwp) THEN
WRITE(numout, FMT = *)
WRITE(numout, FMT = *) 'dom_hgr : define the horizontal mesh from ithe following par_oce parameters '
WRITE(numout, FMT = *) '~~~~~~~ '
WRITE(numout, FMT = *) ' namcfg : read (=T) or user defined (=F) configuration ln_read_cfg = ', ln_read_cfg
END IF
IF (ln_read_cfg) THEN
IF (lwp) WRITE(numout, FMT = *)
IF (lwp) WRITE(numout, FMT = *) ' ==>>> read horizontal mesh in ', TRIM(cn_domcfg), ' file'
CALL hgr_read(glamt, glamu, glamv, glamf, gphit, gphiu, gphiv, gphif, iff, ff_f, ff_t, e1t, e1u, e1v, e1f, e2t, e2u, e2v, e2f, ie1e2u_v, e1e2u, e1e2v)
ELSE
IF (lwp) WRITE(numout, FMT = *)
IF (lwp) WRITE(numout, FMT = *) ' User defined horizontal mesh (usr_def_hgr)'
CALL usr_def_hgr(glamt, glamu, glamv, glamf, gphit, gphiu, gphiv, gphif, iff, ff_f, ff_t, e1t, e1u, e1v, e1f, e2t, e2u, e2v, e2f, ie1e2u_v, e1e2u, e1e2v)
END IF
IF (iff == 0) THEN
IF (lwp) WRITE(numout, FMT = *) ' Coriolis parameter calculated on the sphere from gphif & gphit'
!$ACC KERNELS
ff_f(:, :) = 2. * omega * SIN(rad * gphif(:, :))
ff_t(:, :) = 2. * omega * SIN(rad * gphit(:, :))
!$ACC END KERNELS
ELSE
IF (ln_read_cfg) THEN
IF (lwp) WRITE(numout, FMT = *) ' Coriolis parameter have been read in ', TRIM(cn_domcfg), ' file'
ELSE
IF (lwp) WRITE(numout, FMT = *) ' Coriolis parameter have been set in usr_def_hgr routine'
END IF
END IF
!$ACC KERNELS
r1_e1t(:, :) = 1._wp / e1t(:, :)
r1_e2t(:, :) = 1._wp / e2t(:, :)
r1_e1u(:, :) = 1._wp / e1u(:, :)
r1_e2u(:, :) = 1._wp / e2u(:, :)
r1_e1v(:, :) = 1._wp / e1v(:, :)
r1_e2v(:, :) = 1._wp / e2v(:, :)
r1_e1f(:, :) = 1._wp / e1f(:, :)
r1_e2f(:, :) = 1._wp / e2f(:, :)
e1e2t(:, :) = e1t(:, :) * e2t(:, :)
r1_e1e2t(:, :) = 1._wp / e1e2t(:, :)
e1e2f(:, :) = e1f(:, :) * e2f(:, :)
r1_e1e2f(:, :) = 1._wp / e1e2f(:, :)
!$ACC END KERNELS
IF (ie1e2u_v == 0) THEN
IF (lwp) WRITE(numout, FMT = *) ' u- & v-surfaces calculated as e1 e2 product'
!$ACC KERNELS
e1e2u(:, :) = e1u(:, :) * e2u(:, :)
e1e2v(:, :) = e1v(:, :) * e2v(:, :)
!$ACC END KERNELS
ELSE
IF (lwp) WRITE(numout, FMT = *) ' u- & v-surfaces have been read in "mesh_mask" file:'
IF (lwp) WRITE(numout, FMT = *) ' grid size reduction in strait(s) is used'
END IF
!$ACC KERNELS
r1_e1e2u(:, :) = 1._wp / e1e2u(:, :)
r1_e1e2v(:, :) = 1._wp / e1e2v(:, :)
e2_e1u(:, :) = e2u(:, :) / e1u(:, :)
e1_e2v(:, :) = e1v(:, :) / e2v(:, :)
!$ACC END KERNELS
IF (ln_timing) CALL timing_stop('dom_hgr')
END SUBROUTINE dom_hgr
SUBROUTINE hgr_read(plamt, plamu, plamv, plamf, pphit, pphiu, pphiv, pphif, kff, pff_f, pff_t, pe1t, pe1u, pe1v, pe1f, pe2t, pe2u, pe2v, pe2f, ke1e2u_v, pe1e2u, pe1e2v)
REAL(KIND = wp), DIMENSION(:, :), INTENT(OUT) :: plamt, plamu, plamv, plamf
REAL(KIND = wp), DIMENSION(:, :), INTENT(OUT) :: pphit, pphiu, pphiv, pphif
INTEGER, INTENT(OUT) :: kff
REAL(KIND = wp), DIMENSION(:, :), INTENT(OUT) :: pff_f, pff_t
REAL(KIND = wp), DIMENSION(:, :), INTENT(OUT) :: pe1t, pe1u, pe1v, pe1f
REAL(KIND = wp), DIMENSION(:, :), INTENT(OUT) :: pe2t, pe2u, pe2v, pe2f
INTEGER, INTENT(OUT) :: ke1e2u_v
REAL(KIND = wp), DIMENSION(:, :), INTENT(OUT) :: pe1e2u, pe1e2v
INTEGER :: inum
IF (lwp) THEN
WRITE(numout, FMT = *)
WRITE(numout, FMT = *) ' hgr_read : read the horizontal coordinates in mesh_mask'
WRITE(numout, FMT = *) ' ~~~~~~~~ jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpk = ', jpk
END IF
CALL iom_open(cn_domcfg, inum)
CALL iom_get(inum, jpdom_data, 'glamt', plamt, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'glamu', plamu, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'glamv', plamv, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'glamf', plamf, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'gphit', pphit, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'gphiu', pphiu, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'gphiv', pphiv, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'gphif', pphif, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'e1t', pe1t, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'e1u', pe1u, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'e1v', pe1v, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'e1f', pe1f, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'e2t', pe2t, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'e2u', pe2u, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'e2v', pe2v, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'e2f', pe2f, lrowattr = ln_use_jattr)
IF (iom_varid(inum, 'ff_f', ldstop = .FALSE.) > 0 .AND. iom_varid(inum, 'ff_t', ldstop = .FALSE.) > 0) THEN
IF (lwp) WRITE(numout, FMT = *) ' Coriolis factor at f- and t-points read in ', TRIM(cn_domcfg), ' file'
CALL iom_get(inum, jpdom_data, 'ff_f', pff_f, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'ff_t', pff_t, lrowattr = ln_use_jattr)
kff = 1
ELSE
kff = 0
END IF
IF (iom_varid(inum, 'e1e2u', ldstop = .FALSE.) > 0) THEN
IF (lwp) WRITE(numout, FMT = *) ' e1e2u & e1e2v read in ', TRIM(cn_domcfg), ' file'
CALL iom_get(inum, jpdom_data, 'e1e2u', pe1e2u, lrowattr = ln_use_jattr)
CALL iom_get(inum, jpdom_data, 'e1e2v', pe1e2v, lrowattr = ln_use_jattr)
ke1e2u_v = 1
ELSE
ke1e2u_v = 0
END IF
CALL iom_close(inum)
END SUBROUTINE hgr_read
END MODULE domhgr