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

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90 @ 3849

Last change on this file since 3849 was 3211, checked in by spickles2, 12 years ago

Stephen Pickles, 11 Dec 2011

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