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 on Ticket #159 – Attachment – NEMO

Ticket #159: diadimg.F90

File diadimg.F90, 6.8 KB (added by nemo_user, 17 years ago)

diadimg.F90

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
20   !! * Substitutions
21#  include "domzgr_substitute.h90"
22   !!----------------------------------------------------------------------
23   !!   OPA 9.0 , LOCEAN-IPSL (2005)
24   !! $Header$
25   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
26   !!----------------------------------------------------------------------
27
28CONTAINS
29
30  SUBROUTINE dia_wri_dimg(cd_name, cd_text, ptab, klev, cd_type , ksubi )
31    !!-------------------------------------------------------------------------
32    !!        *** ROUTINE dia_wri_dimg ***
33    !!
34    !! ** Purpose : write ptab in the dimg file cd_name, with comment cd_text.
35    !!       ptab has klev x 2D fields
36    !!
37    !! ** Action :
38    !!       Define header variables from the config parameters
39    !!       Open the dimg file on unit inum = 14 ( IEEE I4R4 file )
40    !!       Write header on record 1
41    !!       Write ptab on the following klev records
42    !!
43    !! History :
44    !!   03-12 (J.M. Molines ) : Original. Replace ctlopn, writn2d
45    !!---------------------------------------------------------------------------
46    !! * Arguments
47    CHARACTER(len=*),INTENT(in) ::   &
48         &                            cd_name,  &  ! dimg file name
49         &                            cd_text      ! comment to write on record #1
50    INTEGER, INTENT(in) ::            klev         ! number of level in ptab to write
51    REAL(wp),INTENT(in), DIMENSION(:,:,:) :: ptab  ! 3D array to write
52    CHARACTER(LEN=1),INTENT(in) ::    cd_type      ! either 'T', 'W' or '2' , depending on the vertical
53    !                                              ! grid for ptab. 2 stands for 2D file
54    INTEGER, INTENT(in), OPTIONAL, DIMENSION(klev) :: ksubi 
55
56    !! * Local declarations
57    INTEGER :: jk, jn           ! dummy loop indices
58    INTEGER :: irecl4,             &    ! record length in bytes
59         &       inum,             &    ! logical unit (set to 14)
60         &       irec                   ! current record to be written
61    REAL(sp)                    :: zdx,zdy,zspval,zwest,ztimm
62    REAL(sp)                    :: zsouth
63    REAL(sp),DIMENSION(jpi,jpj) :: z42d        ! 2d temporary workspace (sp)
64    REAL(sp),DIMENSION(jpk)     :: z4dep       ! vertical level (sp)
65
66    CHARACTER(LEN=80) :: clname                ! name of file in case of dimgnnn
67    CHARACTER(LEN=4) :: clver='@!01'           ! dimg string identifier
68    !!---------------------------------------------------------------------------
69
70    !! * Initialisations
71
72    irecl4 = MAX(jpi*jpj*sp , 84+18*sp + (jpk+8)*jpnij*sp  )
73    inum = 14
74
75    zspval=0.0_sp    ! special values on land
76    !  the 'numerical' grid is described. The geographical one is in a grid file
77    zdx=1._sp
78    zdy=1._sp
79    zsouth=njmpp * 1._sp
80    zwest=nimpp * 1._sp
81    !  time in days since the historical begining of the run (nit000 = 0 )
82    ztimm=adatrj
83
84    SELECT CASE ( cd_type )
85
86    CASE ( 'T')
87       z4dep(:)=gdept_0(:)
88
89    CASE ( 'W' )
90       z4dep(:)=gdepw_0(:)
91
92    CASE ( '2' )
93       z4dep(1:klev) =(/(jk, jk=1,klev)/)
94
95    CASE ( 'I' )
96       z4dep(1:klev) = ksubi(1:klev)
97
98    CASE DEFAULT
99       IF(lwp) WRITE(numout,*) ' E R R O R : bad cd_type in dia_wri_dimg '
100       STOP 'dia_wri_dimg'
101
102    END SELECT
103
104    IF ( ln_dimgnnn  ) THEN
105       WRITE(clname,'(a,a,i3.3)') TRIM(cd_name),'.',narea
106       CALL ctlopn(inum, clname,'UNKNOWN','UNFORMATTED','DIRECT',irecl4,numout,lwp,1)
107       WRITE(inum,REC=1 ) clver, cd_text, irecl4, &
108            &     jpi,jpj, klev, 1 , 1 ,            &
109            &     zwest, zsouth, zdx, zdy, zspval,  &
110            &     z4dep(1:klev),                    &
111            &     ztimm,                            &
112            &     narea, jpnij,jpiglo,jpjglo,jpizoom, jpjzoom,    &    ! extension to dimg for mpp output
113            &     nlcit,nlcjt, nldit, nldjt, nleit, nlejt, nimppt, njmppt  !
114
115       !! * Write klev levels
116       IF ( cd_type == 'I' ) THEN
117
118          DO jk = 1, klev
119             irec =1 + jk
120             z42d(:,:) = ptab(:,:,ksubi(jk))
121             WRITE(inum,REC=irec)  z42d(:,:)
122          END DO
123       ELSE
124          DO jk = 1, klev
125             irec =1 + jk
126             z42d(:,:) = ptab(:,:,jk)
127             WRITE(inum,REC=irec)  z42d(:,:)
128          END DO
129       ENDIF
130    ELSE
131       !! Standard dimgproc (1 file per variable, all procs. write to this file )
132       !! * Open file
133       CALL ctlopn(inum, cd_name,'UNKNOWN','UNFORMATTED','DIRECT',irecl4,numout,lwp,1)
134
135       !! * Write header on record #1
136       IF(lwp) WRITE(inum,REC=1 ) clver, cd_text, irecl4, &
137            &     jpi,jpj, klev*jpnij, 1 , 1 ,            &
138            &     zwest, zsouth, zdx, zdy, zspval,  &
139            &     (z4dep(1:klev),jn=1,jpnij),       &
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 + klev * (narea -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 + klev * (narea -1) + jk
155             z42d(:,:) = ptab(:,:,jk)
156             WRITE(inum,REC=irec)  z42d(:,:)
157          END DO
158       ENDIF
159    ENDIF
160
161    !! * Close the file
162    CLOSE(inum)
163
164  END SUBROUTINE dia_wri_dimg
165
166#  else
167   !!----------------------------------------------------------------------
168   !!   Default option :                                       Empty module
169   !!----------------------------------------------------------------------
170CONTAINS
171
172   SUBROUTINE dia_wri_dimg( cd_name, cd_exper, ptab, klev, cd_type )
173      REAL, DIMENSION(:,:,:) :: ptab
174      INTEGER :: klev
175      CHARACTER(LEN=80) :: cd_name, cd_exper,cd_type
176      WRITE(*,*) ' This print must never occur ', cd_name, cd_exper,ptab, klev, cd_type
177      WRITE(*,*) ' this routine is here just for compilation '
178   END SUBROUTINE dia_wri_dimg
179# endif
180   !!======================================================================
181END MODULE diadimg