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

source: trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90 @ 2715

Last change on this file since 2715 was 2715, checked in by rblod, 13 years ago

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