New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
utils.F90 in branches/2015/dev_r5187_UKMO13_simplification/NEMOGCM/TOOLS/SCOORD_GEN/src – NEMO

source: branches/2015/dev_r5187_UKMO13_simplification/NEMOGCM/TOOLS/SCOORD_GEN/src/utils.F90 @ 5257

Last change on this file since 5257 was 5257, checked in by timgraham, 9 years ago

Fixed lots of compilation errors

File size: 9.3 KB
Line 
1MODULE utils
2
3   USE netcdf
4
5   IMPLICIT NONE
6   PUBLIC             ! allows the acces to par_oce when dom_oce is used
7   !                  ! exception to coding rules... to be suppressed ???
8
9!   PUBLIC dom_oce_alloc
10
11   INTEGER, PARAMETER   :: dp=8 , sp=4, wp=dp
12
13   !! All coordinates
14   !! ---------------
15   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdep3w_0           !: depth of t-points (sum of e3w) (m)
16   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept_0, gdepw_0   !: analytical (time invariant) depth at t-w  points (m)
17   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3v_0  , e3f_0     !: analytical (time invariant) vertical scale factors at  v-f
18   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t_0  , e3u_0     !:                                      t-u  points (m)
19   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3vw_0             !: analytical (time invariant) vertical scale factors at  vw
20   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3w_0  , e3uw_0    !:                                      w-uw points (m)
21
22   !! s-coordinate and hybrid z-s-coordinate
23   !! =----------------======---------------
24   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   gsigt, gsigw       !: model level depth coefficient at t-, w-levels (analytic)
25   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   gsi3w              !: model level depth coefficient at w-level (sum of gsigw)
26   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   esigt, esigw       !: vertical scale factor coef. at t-, w-levels
27
28   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hbatv , hbatf      !: ocean depth at the vertical of  v--f
29   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hbatt , hbatu      !:                                 t--u points (m)
30   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   scosrf, scobot     !: ocean surface and bottom topographies
31   !                                                                           !  (if deviating from coordinate surfaces in HYBRID)
32   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hifv  , hiff       !: interface depth between stretching at v--f
33   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hift  , hifu       !: and quasi-uniform spacing             t--u points (m)
34   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rx1                !: Maximum grid stiffness ratio
35
36   !!----------------------------------------------------------------------
37   !! masks, bathymetry
38   !! ---------------------------------------------------------------------
39   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbathy             !: number of ocean level (=0, 1, ... , jpk-1)
40   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bathy              !: ocean depth (meters - read from file)
41
42   !! Other variables needed by scoord_gen
43   INTEGER  ::   jpi, jpj, jpk            ! Size of the domain - read from bathy or namelist?
44   INTEGER  ::   ji, jj, jk, jl           ! dummy loop argument
45   INTEGER  ::   iip1, ijp1, iim1, ijm1   ! temporary integers
46   INTEGER  ::   ios                      ! Local integer output status for namelist read and allocation
47   INTEGER  ::   numnam                   ! File handle for namelist
48   REAL(wp) ::   zrmax, ztaper   ! temporary scalars
49   REAL(wp) ::   zrfact
50   !
51   REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmpi1, ztmpi2, ztmpj1, ztmpj2
52   REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zenv, ztmp, zmsk, zri, zrj, zhbat
53
54   !Namelist variables
55   REAL(wp) :: rn_jpk, rn_sbot_min, rn_sbot_max, rn_hc, rn_rmax, rn_theta
56   REAL(wp) :: rn_thetb, rn_bb, rn_alpha, rn_efold, rn_zs, rn_zb_a, rn_zb_b
57   LOGICAL :: ln_s_sh94, ln_s_sf12, ln_sigcrit
58
59   NAMELIST/namzgr_sco/rn_jpk, ln_s_sh94, ln_s_sf12, ln_sigcrit, rn_sbot_min, rn_sbot_max, rn_hc, rn_rmax,rn_theta, &
60                        rn_thetb, rn_bb, rn_alpha, rn_efold, rn_zs, rn_zb_a, rn_zb_b
61
62   CONTAINS
63
64   INTEGER FUNCTION dom_oce_alloc()
65      !!----------------------------------------------------------------------
66      INTEGER, DIMENSION(4) :: ierr
67      !!----------------------------------------------------------------------
68      ierr(:) = 0
69      !
70      ALLOCATE( zenv(jpi,jpj), ztmp(jpi,jpj), zmsk(jpi,jpj), zri(jpi,jpj), zrj(jpi,jpj), &
71         &      zhbat(jpi,jpj) , ztmpi1(jpi,jpj), ztmpi2(jpi,jpj), ztmpj1(jpi,jpj), ztmpj2(jpi,jpj), STAT=ierr(1) )
72         !
73      ALLOCATE( gdep3w_0(jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) ,                         &
74         &      gdept_0(jpi,jpj,jpk) , e3t_0(jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) ,                         &
75         &      gdepw_0(jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , STAT=ierr(2) )
76         !
77         !
78         !
79      ALLOCATE( hbatv (jpi,jpj) , hbatf (jpi,jpj) ,     &
80         &      hbatt (jpi,jpj) , hbatu (jpi,jpj) ,     &
81         &      scosrf(jpi,jpj) , scobot(jpi,jpj) ,     &
82         &      hifv  (jpi,jpj) , hiff  (jpi,jpj) ,     &
83         &      hift  (jpi,jpj) , hifu  (jpi,jpj) , rx1 (jpi,jpj) , STAT=ierr(3) )
84
85      ALLOCATE( mbathy(jpi,jpj) , STAT=ierr(4) )
86     !
87      dom_oce_alloc = MAXVAL(ierr)
88      !
89   END FUNCTION dom_oce_alloc
90   
91
92   SUBROUTINE read_bathy()
93     !! Read bathymetry from input netcdf file
94     INTEGER :: var_id, ncin
95
96     CALL check_nf90( nf90_open('bathy.nc', NF90_NOWRITE, ncin), 'Error opening bathy.nc file' )
97
98     ! Find the size of the input bathymetry
99     CALL dimlen(ncin, 'x', jpi)   
100     CALL dimlen(ncin, 'y', jpj)   
101     
102     ALLOCATE( bathy(jpi, jpj) )
103     
104     ! Read the bathymetry variable from file
105     CALL check_nf90( nf90_inq_varid( ncin, 'bathymetry', var_id ), 'Cannot get variable ID for bathymetry')
106     CALL check_nf90( nf90_get_var( ncin, var_id, bathy, (/ 1,1 /), (/ jpi, jpj /) ) )
107
108     CALL check_nf90( nf90_close(ncin), 'Error closing bathy.nc file' )
109
110   END SUBROUTINE read_bathy
111
112   SUBROUTINE dimlen( ncid, dimname, len )
113     ! Determine the length of dimension dimname
114     INTEGER, INTENT(in)          :: ncid
115     CHARACTER(LEN=*), INTENT(in) :: dimname
116     INTEGER, INTENT(out)         :: len
117     ! Local variables
118     INTEGER :: id_var, istatus
119
120     id_var = 1
121     CALL check_nf90( nf90_inq_dimid(ncid, dimname, id_var), 'Dimension not found in file')
122     CALL check_nf90( nf90_inquire_dimension(ncid,id_var,len=len))
123
124   END SUBROUTINE dimlen
125 
126 
127   SUBROUTINE write_coord_file()
128     ! Write out variables to the a netcdf coordinates file
129     
130     INTEGER :: id_x, id_y, id_z
131     INTEGER :: ncout
132     INTEGER, DIMENSION(11) :: var_ids  !Array to contain all variable IDs
133
134     !Create the file
135     CALL check_nf90( nf90_create('coord_zgr.nc', NF90_CLOBBER, ncout), 'Could not create output file')
136     !
137     !Define dimensions
138     CALL check_nf90( nf90_def_dim(ncout, 'x', jpi, id_x) )
139     CALL check_nf90( nf90_def_dim(ncout, 'y', jpj, id_y) )
140     CALL check_nf90( nf90_def_dim(ncout, 'z', jpk, id_z) )
141     !
142     !Define variables
143     CALL check_nf90( nf90_def_var(ncout, 'gdept_0', nf90_double, (/id_x, id_y,id_x/), var_ids(1)) )
144     CALL check_nf90( nf90_def_var(ncout, 'gdepw_0', nf90_double, (/id_x, id_y,id_x/), var_ids(2)) )
145     CALL check_nf90( nf90_def_var(ncout, 'gdep3w_0', nf90_double, (/id_x, id_y,id_x/), var_ids(3)) )
146     CALL check_nf90( nf90_def_var(ncout, 'e3f_0', nf90_double, (/id_x, id_y,id_x/), var_ids(4)) )
147     CALL check_nf90( nf90_def_var(ncout, 'e3t_0', nf90_double, (/id_x, id_y,id_x/), var_ids(5)) )
148     CALL check_nf90( nf90_def_var(ncout, 'e3u_0', nf90_double, (/id_x, id_y,id_x/), var_ids(6)) )
149     CALL check_nf90( nf90_def_var(ncout, 'e3v_0', nf90_double, (/id_x, id_y,id_x/), var_ids(7)) )
150     CALL check_nf90( nf90_def_var(ncout, 'e3w_0', nf90_double, (/id_x, id_y,id_x/), var_ids(8)) )
151     CALL check_nf90( nf90_def_var(ncout, 'e3uw_0', nf90_double, (/id_x, id_y,id_x/), var_ids(9)) )
152     CALL check_nf90( nf90_def_var(ncout, 'e3vw_0', nf90_double, (/id_x, id_y,id_x/), var_ids(10)) )
153     CALL check_nf90( nf90_def_var(ncout, 'mbathy', nf90_double, (/id_x, id_y,id_x/), var_ids(11)) )
154     
155     ! End define mode
156     CALL check_nf90( nf90_enddef(ncout) )
157
158     !Write variables to file
159     CALL check_nf90( nf90_put_var(ncout, var_ids(1), gdept_0) )
160     CALL check_nf90( nf90_put_var(ncout, var_ids(2), gdepw_0) )
161     CALL check_nf90( nf90_put_var(ncout, var_ids(3), gdep3w_0) )
162     CALL check_nf90( nf90_put_var(ncout, var_ids(4), e3f_0) )
163     CALL check_nf90( nf90_put_var(ncout, var_ids(5), e3t_0) )
164     CALL check_nf90( nf90_put_var(ncout, var_ids(6), e3u_0) )
165     CALL check_nf90( nf90_put_var(ncout, var_ids(7), e3v_0) )
166     CALL check_nf90( nf90_put_var(ncout, var_ids(8), e3w_0) )
167     CALL check_nf90( nf90_put_var(ncout, var_ids(9), e3uw_0) )
168     CALL check_nf90( nf90_put_var(ncout, var_ids(10), e3vw_0) )
169     CALL check_nf90( nf90_put_var(ncout, var_ids(11), mbathy) )
170     
171     CALL check_nf90( nf90_close(ncout) )
172
173   END SUBROUTINE write_coord_file
174
175   SUBROUTINE check_nf90( istat, message )
176      !Check for netcdf errors
177      INTEGER, INTENT(in) :: istat
178      CHARACTER(LEN=*), INTENT(in), OPTIONAL :: message
179
180      IF (istat /= nf90_noerr) THEN
181         WRITE(*,*) 'ERROR! : '//TRIM(nf90_strerror(istat))
182         IF ( PRESENT(message) ) THEN ; WRITE(*,*) message ; ENDIF
183         STOP
184      ENDIF
185
186   END SUBROUTINE check_nf90
187
188
189END MODULE utils
Note: See TracBrowser for help on using the repository browser.