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/dev_r5518_MO_couple_package/NEMOGCM/NEMO/OPA_SRC/DIA – NEMO

source: branches/UKMO/dev_r5518_MO_couple_package/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90 @ 6544

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

Add by hand, relevant changes ONLY, from
fcm:NEMO.xm/branches/UKMO/dev_r5107_hadgem3_cplseq from revisions 5279 to 5303.

Note: we no longer employ a separate CPP key for key_oasis3mct and simply intend
to use the NEMO base code key_oasis3.

Note also that most, if not all the changnes made here are things which should
go to the nemo trunk since they involve improvements to error messages, shutdown
processes and abort handling.
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       WRITE(numout,*) 'dia_wri_dimg : E R R O R : bad cd_type in dia_wri_dimg'
127       CALL ctl_stop( 'STOP', 'dia_wri_dimg :bad cd_type in dia_wri_dimg ' )
128
129    END SELECT
130
131    IF ( ln_dimgnnn  ) THEN
132     irecl4 = MAX(jpi*jpj*sp , 84+(18+jpk)*sp + 8*jpnij*sp  )
133       WRITE(clname,'(a,a,i3.3)') TRIM(cd_name),'.',narea
134       CALL ctl_opn(inum, clname,'UNKNOWN','UNFORMATTED','DIRECT',irecl4,numout,lwp)
135       WRITE(inum,REC=1 ) clver, cd_text, irecl4, &
136            &     jpi,jpj, klev, 1 , 1 ,            &
137            &     zwest, zsouth, zdx, zdy, zspval,  &
138            &     z4dep(1:klev),                    &
139            &     ztimm,                            &
140            &     narea, jpnij,jpiglo,jpjglo,jpizoom, jpjzoom,    &    ! extension to dimg for mpp output
141            &     nlcit,nlcjt, nldit, nldjt, nleit, nlejt, nimppt, njmppt  !
142
143       !! * Write klev levels
144       IF ( cd_type == 'I' ) THEN
145
146          DO jk = 1, klev
147             irec =1 + jk
148             z42d(:,:) = ptab(:,:,ksubi(jk))
149             WRITE(inum,REC=irec)  z42d(:,:)
150          END DO
151       ELSE
152          DO jk = 1, klev
153             irec =1 + jk
154             z42d(:,:) = ptab(:,:,jk)
155             WRITE(inum,REC=irec)  z42d(:,:)
156          END DO
157       ENDIF
158    ELSE
159       clver='@!03'           ! dimg string identifier
160       ! note that version @!02 is optimized with respect to record length.
161       ! The vertical dep variable is reduced to klev instead of klev*jpnij :
162       !   this is OK for jpnij < 181 (jpk=46)
163       ! for more processors, irecl4 get huge and that's why we switch to '@!03':
164       !  In this case we just add an extra integer to the standard dimg structure,
165       !  which is a record number where the arrays nlci etc... starts (1 per record)
166       
167       !! Standard dimgproc (1 file per variable, all procs. write to this file )
168       !! * Open file
169       CALL ctl_opn(inum, cd_name,'UNKNOWN','UNFORMATTED','DIRECT',irecl4,numout,lwp)
170
171       !! * Write header on record #1
172       irecend=1 + klev*jpnij 
173       IF(lwp) WRITE(inum,REC=1 ) clver, cd_text, irecl4, &
174            &     jpi,jpj, klev, 1 , 1 ,            &
175            &     zwest, zsouth, zdx, zdy, zspval,  &
176            &     z4dep(1:klev),       &
177            &     ztimm,                            &
178            &     narea, jpnij,jpiglo,jpjglo,jpizoom, jpjzoom, irecend 
179       IF (lwp ) THEN
180         WRITE(inum,REC=irecend + 1 ) nlcit
181         WRITE(inum,REC=irecend + 2 ) nlcjt
182         WRITE(inum,REC=irecend + 3 ) nldit
183         WRITE(inum,REC=irecend + 4 ) nldjt
184         WRITE(inum,REC=irecend + 5 ) nleit
185         WRITE(inum,REC=irecend + 6 ) nlejt
186         WRITE(inum,REC=irecend + 7 ) nimppt
187         WRITE(inum,REC=irecend + 8 ) njmppt
188       ENDIF
189      !   &    ! extension to dimg for mpp output
190      !   &     nlcit,nlcjt, nldit, nldjt, nleit, nlejt, nimppt, njmppt  !
191
192       !! * Write klev levels
193       IF ( cd_type == 'I' ) THEN
194
195          DO jk = 1, klev
196             irec =1 + klev * (narea -1) + jk
197             z42d(:,:) = ptab(:,:,ksubi(jk))
198             WRITE(inum,REC=irec)  z42d(:,:)
199          END DO
200       ELSE
201          DO jk = 1, klev
202             irec =1 + klev * (narea -1) + jk
203             z42d(:,:) = ptab(:,:,jk)
204             WRITE(inum,REC=irec)  z42d(:,:)
205          END DO
206       ENDIF
207    ENDIF
208
209    !! * Close the file
210    CLOSE(inum)
211
212  END SUBROUTINE dia_wri_dimg
213
214#  else
215   !!----------------------------------------------------------------------
216   !!   Default option :                                       Empty module
217   !!----------------------------------------------------------------------
218CONTAINS
219
220   SUBROUTINE dia_wri_dimg( cd_name, cd_exper, ptab, klev, cd_type )
221      REAL, DIMENSION(:,:,:) :: ptab
222      INTEGER :: klev
223      CHARACTER(LEN=80) :: cd_name, cd_exper,cd_type
224      WRITE(*,*) ' This print must never occur ', cd_name, cd_exper,ptab, klev, cd_type
225      WRITE(*,*) ' this routine is here just for compilation '
226   END SUBROUTINE dia_wri_dimg
227# endif
228   !!======================================================================
229END MODULE diadimg
Note: See TracBrowser for help on using the repository browser.