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.
diadimg.F90 in branches/UKMO/nemo_v3_6_STABLE_pkg/NEMOGCM/NEMO/OPA_SRC/DIA – NEMO

source: branches/UKMO/nemo_v3_6_STABLE_pkg/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90 @ 6254

Last change on this file since 6254 was 6254, checked in by frrh, 8 years ago

Merge branches/UKMO/dev_r5107_hadgem3_mct@5679 (not 5631 as used in
original GO6.1 which I was supplied with! This has extra, meaningful,
error trapping in place of the original inappropriate use of "STOP"
which is useless in the context of coupled models.

Again merging this branch proved far more awkward than it should
be with spurious claims of conflicts in various irrelevant files
in NEMOGCM/ARCH/ and DOC/TexFiles which I reverted before committing.
File size: 9.0 KB
Line 
1MODULE diadimg
2   !!======================================================================
3   !!                     ***  MODULE  diadimg  ***
4   !! Ocean diagnostics :  write ocean output files in dimg direct access format (mpp)
5   !!=====================================================================
6# if defined key_dimgout
7   !!----------------------------------------------------------------------
8   USE oce             ! ocean dynamics and tracers
9   USE dom_oce         ! ocean space and time domain
10   USE in_out_manager  ! I/O manager
11   USE daymod          ! calendar
12   USE lib_mpp
13
14   IMPLICIT NONE
15   PRIVATE
16
17   PUBLIC dia_wri_dimg            ! called by trd_mld (eg)
18   PUBLIC dia_wri_dimg_alloc      ! called by nemo_alloc in nemogcm.F90
19
20
21   !! These workspace arrays are inside the module so that we can make them
22   !! allocatable in a clean way. Not done in wrk_nemo because these are of KIND(sp).
23   REAL(sp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: z42d    ! 2d temporary workspace (sp)
24   REAL(sp), ALLOCATABLE, SAVE, DIMENSION(:)   :: z4dep   ! vertical level (sp)
25
26   !! * Substitutions
27#  include "domzgr_substitute.h90"
28   !!----------------------------------------------------------------------
29   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
30   !! $Id$
31   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
32   !!----------------------------------------------------------------------
33CONTAINS
34
35   FUNCTION dia_wri_dimg_alloc()
36      !!---------------------------------------------------------------------
37      !!        *** ROUTINE dia_wri_dimg_alloc ***
38      !!
39      !!---------------------------------------------------------------------
40      INTEGER :: dia_wri_dimg_alloc   ! return value
41      !!---------------------------------------------------------------------
42      !
43      IF( .NOT. ALLOCATED( z42d ) )THEN
44
45         ALLOCATE( z42d(jpi,jpj), z4dep(jpk), STAT=dia_wri_dimg_alloc )
46
47         IF( lk_mpp                  )   CALL mpp_sum ( dia_wri_dimg_alloc )
48         IF( dia_wri_dimg_alloc /= 0 )   CALL ctl_warn('dia_wri_dimg_alloc: allocation of array failed.')
49
50      ELSE
51
52         dia_wri_dimg_alloc = 0
53
54      ENDIF
55      !
56  END FUNCTION dia_wri_dimg_alloc
57
58
59  SUBROUTINE dia_wri_dimg( cd_name, cd_text, ptab, klev, cd_type , ksubi )
60    !!-------------------------------------------------------------------------
61    !!        *** ROUTINE dia_wri_dimg ***
62    !!
63    !! ** Purpose :   write ptab in the dimg file cd_name, with comment cd_text.
64    !!              ptab has klev x 2D fields
65    !!
66    !! ** Action :   Define header variables from the config parameters
67    !!               Open the dimg file on unit inum = 14 ( IEEE I4R4 file )
68    !!               Write header on record 1
69    !!               Write ptab on the following klev records
70    !!
71    !! History :  2003-12 (J.M. Molines ) : Original. Replace ctl_opn, writn2d
72    !!---------------------------------------------------------------------------
73    CHARACTER(len=*),INTENT(in) ::   &
74         &                            cd_name,  &  ! dimg file name
75         &                            cd_text      ! comment to write on record #1
76    INTEGER, INTENT(in) ::            klev         ! number of level in ptab to write
77    REAL(wp),INTENT(in), DIMENSION(:,:,:) :: ptab  ! 3D array to write
78    CHARACTER(LEN=1),INTENT(in) ::    cd_type      ! either 'T', 'W' or '2' , depending on the vertical
79    !                                              ! grid for ptab. 2 stands for 2D file
80    INTEGER, INTENT(in), OPTIONAL, DIMENSION(klev) :: ksubi 
81
82    !! * Local declarations
83    INTEGER :: jk, jn           ! dummy loop indices
84    INTEGER :: irecl4,             &    ! record length in bytes
85         &       inum,             &    ! logical unit (set to 14)
86         &       irec,             &    ! current record to be written
87         &       irecend                ! record number where nclit... are stored
88    REAL(sp)                    :: zdx,zdy,zspval,zwest,ztimm
89    REAL(sp)                    :: zsouth
90
91    CHARACTER(LEN=80) :: clname                ! name of file in case of dimgnnn
92    CHARACTER(LEN=4) :: clver='@!01'           ! dimg string identifier
93    !!---------------------------------------------------------------------------
94
95    !                                      ! allocate dia_wri_dimg array
96    IF( dia_wri_dimg_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_wri_dimg : unable to allocate arrays' )
97
98    !! * Initialisations
99
100    irecl4 = MAX(jpi*jpj*sp , 84+(18+1+jpk)*sp )
101
102    zspval=0.0_sp    ! special values on land
103    !  the 'numerical' grid is described. The geographical one is in a grid file
104    zdx=1._sp
105    zdy=1._sp
106    zsouth=njmpp * 1._sp
107    zwest=nimpp * 1._sp
108    !  time in days since the historical begining of the run (nit000 = 0 )
109    ztimm=adatrj
110
111    SELECT CASE ( cd_type )
112
113    CASE ( 'T')
114       z4dep(:)=gdept_1d(:)
115
116    CASE ( 'W' )
117       z4dep(:)=gdepw_1d(:)
118
119    CASE ( '2' )
120       z4dep(1:klev) =(/(jk, jk=1,klev)/)
121
122    CASE ( 'I' )
123       z4dep(1:klev) = ksubi(1:klev)
124
125    CASE DEFAULT
126   
127       WRITE(numout,*) 'dia_wri_dimg : E R R O R : bad cd_type in dia_wri_dimg'
128       CALL ctl_stop( 'STOP', 'dia_wri_dimg :bad cd_type in dia_wri_dimg ' )
129
130    END SELECT
131
132    IF ( ln_dimgnnn  ) THEN
133     irecl4 = MAX(jpi*jpj*sp , 84+(18+jpk)*sp + 8*jpnij*sp  )
134       WRITE(clname,'(a,a,i3.3)') TRIM(cd_name),'.',narea
135       CALL ctl_opn(inum, clname,'UNKNOWN','UNFORMATTED','DIRECT',irecl4,numout,lwp)
136       WRITE(inum,REC=1 ) clver, cd_text, irecl4, &
137            &     jpi,jpj, klev, 1 , 1 ,            &
138            &     zwest, zsouth, zdx, zdy, zspval,  &
139            &     z4dep(1:klev),                    &
140            &     ztimm,                            &
141            &     narea, jpnij,jpiglo,jpjglo,jpizoom, jpjzoom,    &    ! extension to dimg for mpp output
142            &     nlcit,nlcjt, nldit, nldjt, nleit, nlejt, nimppt, njmppt  !
143
144       !! * Write klev levels
145       IF ( cd_type == 'I' ) THEN
146
147          DO jk = 1, klev
148             irec =1 + jk
149             z42d(:,:) = ptab(:,:,ksubi(jk))
150             WRITE(inum,REC=irec)  z42d(:,:)
151          END DO
152       ELSE
153          DO jk = 1, klev
154             irec =1 + jk
155             z42d(:,:) = ptab(:,:,jk)
156             WRITE(inum,REC=irec)  z42d(:,:)
157          END DO
158       ENDIF
159    ELSE
160       clver='@!03'           ! dimg string identifier
161       ! note that version @!02 is optimized with respect to record length.
162       ! The vertical dep variable is reduced to klev instead of klev*jpnij :
163       !   this is OK for jpnij < 181 (jpk=46)
164       ! for more processors, irecl4 get huge and that's why we switch to '@!03':
165       !  In this case we just add an extra integer to the standard dimg structure,
166       !  which is a record number where the arrays nlci etc... starts (1 per record)
167       
168       !! Standard dimgproc (1 file per variable, all procs. write to this file )
169       !! * Open file
170       CALL ctl_opn(inum, cd_name,'UNKNOWN','UNFORMATTED','DIRECT',irecl4,numout,lwp)
171
172       !! * Write header on record #1
173       irecend=1 + klev*jpnij 
174       IF(lwp) WRITE(inum,REC=1 ) clver, cd_text, irecl4, &
175            &     jpi,jpj, klev, 1 , 1 ,            &
176            &     zwest, zsouth, zdx, zdy, zspval,  &
177            &     z4dep(1:klev),       &
178            &     ztimm,                            &
179            &     narea, jpnij,jpiglo,jpjglo,jpizoom, jpjzoom, irecend 
180       IF (lwp ) THEN
181         WRITE(inum,REC=irecend + 1 ) nlcit
182         WRITE(inum,REC=irecend + 2 ) nlcjt
183         WRITE(inum,REC=irecend + 3 ) nldit
184         WRITE(inum,REC=irecend + 4 ) nldjt
185         WRITE(inum,REC=irecend + 5 ) nleit
186         WRITE(inum,REC=irecend + 6 ) nlejt
187         WRITE(inum,REC=irecend + 7 ) nimppt
188         WRITE(inum,REC=irecend + 8 ) njmppt
189       ENDIF
190      !   &    ! extension to dimg for mpp output
191      !   &     nlcit,nlcjt, nldit, nldjt, nleit, nlejt, nimppt, njmppt  !
192
193       !! * Write klev levels
194       IF ( cd_type == 'I' ) THEN
195
196          DO jk = 1, klev
197             irec =1 + klev * (narea -1) + jk
198             z42d(:,:) = ptab(:,:,ksubi(jk))
199             WRITE(inum,REC=irec)  z42d(:,:)
200          END DO
201       ELSE
202          DO jk = 1, klev
203             irec =1 + klev * (narea -1) + jk
204             z42d(:,:) = ptab(:,:,jk)
205             WRITE(inum,REC=irec)  z42d(:,:)
206          END DO
207       ENDIF
208    ENDIF
209
210    !! * Close the file
211    CLOSE(inum)
212
213  END SUBROUTINE dia_wri_dimg
214
215#  else
216   !!----------------------------------------------------------------------
217   !!   Default option :                                       Empty module
218   !!----------------------------------------------------------------------
219CONTAINS
220
221   SUBROUTINE dia_wri_dimg( cd_name, cd_exper, ptab, klev, cd_type )
222      REAL, DIMENSION(:,:,:) :: ptab
223      INTEGER :: klev
224      CHARACTER(LEN=80) :: cd_name, cd_exper,cd_type
225      WRITE(*,*) ' This print must never occur ', cd_name, cd_exper,ptab, klev, cd_type
226      WRITE(*,*) ' this routine is here just for compilation '
227   END SUBROUTINE dia_wri_dimg
228# endif
229   !!======================================================================
230END MODULE diadimg
Note: See TracBrowser for help on using the repository browser.