Philippe 23/02/2016: lfi2cdf: modif for JPHEXT/=1
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / FM / fm_writ.f90
1 !     ###########################################################
2       SUBROUTINE FM_WRIT(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
3                         KLENCH,HCOMMENT,KRESP)
4 !     ###########################################################
5 !
6 !!****  *FM_WRIT* - routine to write a single data article into a "FM"-file
7 !!
8 !!    PURPOSE
9 !!    -------
10 !
11 !       The purpose of FMWRIT is to write one article into a Meso-nh data file.
12 !     This routine only holds for a LFI-file (not namelist).
13 !
14 !!**  METHOD
15 !!    ------
16 !!
17 !!      The unformatted write operation is actually performed by the routine
18 !!    LFIECR. You need to indicate the file name without the ".lfi"
19 !!    suffix, the data array and the
20 !!    length of this array. Furthermore, you have to give a name for the article
21 !!    you are writing (string) which you better choose by convention.
22 !!      FMWRIT also appends the grid-indicator (KGRID) at the beginning of
23 !!    the LFI logical article (IWORK(1)) ; then the length of the comment
24 !!    string (KLENCH) ; then the comment string itself which is first
25 !!    converted into integer type using ICHAR.
26 !!    Finally, it writes the data (integer or
27 !!    real) itself (rest of array IWORK). We stress that the length KLENG
28 !!    that the user has to indicate is the length of the real data array
29 !!    WITHOUT taking the other fields into account.
30 !!
31 !!    EXTERNAL
32 !!    --------
33 !!
34 !!      FMLOOK,LFIECR,ICHAR
35 !!
36 !!    IMPLICIT ARGUMENTS
37 !!    ------------------
38 !!
39 !!      MODULE: MODD_FMDECLAR contains management parameters and
40 !!              storage arrays to move information around at the
41 !!              level of all "FM"-routines.
42 !!
43 !!    REFERENCE
44 !!    ---------
45 !!
46 !!      see the Technical Specifications Report for the Meso-nh project
47 !!      (in French)
48 !!
49 !!    AUTHOR
50 !!    ------
51 !!
52 !!      C. FISCHER      *METEO-FRANCE*
53 !!
54 !!    MODIFICATIONS
55 !!    -------------
56 !!
57 !!      original                                                        06/94
58 !!      modified by V. Masson               16/09/96 (prints if error occurs)
59 !----------------------------------------------------------------------------
60 !
61 !*      0.    DECLARATIONS
62 !             ------------
63 !
64 USE MODD_FMDECLAR
65
66 IMPLICIT NONE
67 !
68 !*      0.1   Declarations of arguments
69 !
70 CHARACTER(LEN=*)          ,INTENT(IN) ::HFILEM   ! file name
71 CHARACTER(LEN=*)          ,INTENT(IN) ::HRECFM   ! name of the article to be written
72
73 CHARACTER(LEN=*)          ,INTENT(IN) ::HFIPRI   ! file for prints in FM
74
75 INTEGER,                   INTENT(IN) ::KLENG  ! length of the data field
76 INTEGER(KIND=8),DIMENSION(1:KLENG),INTENT(IN) ::KFIELD ! array containing the data field
77 INTEGER,                   INTENT(IN) ::KGRID  ! C-grid indicator (u,v,w,T)
78 INTEGER,                   INTENT(IN) ::KLENCH ! length of comment string
79
80 CHARACTER(LEN=KLENCH),     INTENT(IN) ::HCOMMENT ! comment string)
81
82 INTEGER,                   INTENT(OUT)::KRESP  ! return-code if problems araised
83
84 !
85 !*      0.2   Declarations of local variables
86 !
87 INTEGER::IRESP,ITOTAL,INUMBR,J,IROW,IFMFNL,ILUPRI
88 INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE::IWORK
89 INTEGER,DIMENSION(1:JPXKRK)::ICOMMENT
90 CHARACTER(LEN=JPFINL)::YFNLFI
91 CHARACTER(LEN=LEN(HFILEM))::YINTFN
92 !
93 !*      0.3   Taskcommon for logical units
94 !
95 COMMON/TASKWRIT/ILUPRI,INUMBR,IRESP
96 !DIR$ TASKCOMMON TASKWRIT
97 !
98 !----------------------------------------------------------------------------
99 !
100 !*      1.1   THE NAME OF LFIFM
101 !
102 IRESP = 0 ; IROW = 0 ; ILUPRI = 6
103 IFMFNL=JPFINL-4
104
105 IROW=LEN(HFILEM)
106
107 IF (IROW.EQ.0) THEN
108    IRESP=-64
109    GOTO 1000
110 ELSEIF (IROW.GT.IFMFNL) THEN
111    IRESP=-65
112    GOTO 1000
113 ENDIF
114 YINTFN=ADJUSTR(HFILEM)
115 YFNLFI=YINTFN//'.lfi'
116 YFNLFI=ADJUSTL(YFNLFI)
117
118 !
119 !*      1.2   WE LOOK FOR THE FILE'S LOGICAL UNIT
120 !
121 CALL FMLOOK(YFNLFI,HFIPRI,INUMBR,IRESP)
122 IF (IRESP.NE.0) GOTO 1000
123
124 !
125 !*      2.    GRID INDICATOR, COMMENT AND DATA ARE PUT TOGETHER
126 !
127 IF (KLENG.LE.0) THEN
128     IRESP=-40
129     GOTO 1000
130 ELSEIF (KLENG.GT.JPXFIE) THEN
131     IRESP=-43
132     GOTO 1000
133 ELSEIF ((KGRID.LT.0).OR.(KGRID.GT.8)) THEN
134     IRESP=-46
135     GOTO 1000
136 ENDIF
137
138 ITOTAL=KLENG+1+KLENCH+1
139 IF(ALLOCATED(IWORK)) DEALLOCATE(IWORK)
140 ALLOCATE(IWORK(ITOTAL))
141
142 IWORK(1)=KGRID
143
144 SELECT CASE (KLENCH)
145 CASE(:-1)
146     IRESP=-55
147     GOTO 1000
148 CASE(0)
149     IWORK(2)=KLENCH
150     IWORK(3:KLENG+2)=KFIELD(1:KLENG)
151 CASE(1:JPXKRK)
152     DO J=1,KLENCH
153         ICOMMENT(J)=ICHAR(HCOMMENT(J:J))
154     ENDDO
155     IWORK(2)=KLENCH
156     IWORK(3:KLENCH+2)=ICOMMENT(1:KLENCH)
157     IWORK(KLENCH+3:ITOTAL)=KFIELD(1:KLENG)
158 CASE(JPXKRK+1:)
159     IRESP=-57
160     GOTO 1000
161 END SELECT
162
163 !
164 !  no compressing of any kind: the data is pure binary
165 !
166 !*      3.    UNFORMATTED, DIRECT ACCESS WRITE OPERATION
167 !
168 CALL LFIECR(IRESP,INUMBR,HRECFM,IWORK,ITOTAL)
169 IF (IRESP.NE.0) GOTO 1000
170
171 DEALLOCATE(IWORK)
172 !
173 !*      4.    MESSAGE PRINTING WHATEVER THE ISSUE WAS
174 !
175 1000    CONTINUE
176
177 IF (IRESP.NE.0) THEN
178 YFNLFI=ADJUSTL(HFIPRI)
179 DO J=1,JPNXLU
180     IF (CNAMFI(J).EQ.YFNLFI) THEN
181        ILUPRI=J
182        EXIT
183     ENDIF
184 ENDDO
185 WRITE (ILUPRI,*) ' exit from FMWRIT with IRESP:',IRESP
186 WRITE (ILUPRI,*) '   | HFILEM = ',HFILEM
187 WRITE (ILUPRI,*) '   | HRECFM = ',HRECFM
188 WRITE (ILUPRI,*) '   | KLENG  = ',KLENG
189 WRITE (ILUPRI,*) '   | KGRID  = ',KGRID
190 WRITE (ILUPRI,*) '   | KLENCH = ',KLENCH
191 ENDIF
192 KRESP=IRESP
193
194 RETURN
195       END SUBROUTINE FM_WRIT