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

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90 @ 2590

Last change on this file since 2590 was 2590, checked in by trackstand2, 13 years ago

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