Philippe 23/02/2016: lfi2cdf: modif for JPHEXT/=1
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / FM / fmclos.f90
1 !     #############################################
2       SUBROUTINE FMCLOS(HFILEM,HSTATU,HFIPRI,KRESP)
3 !     #############################################
4 !
5 !!****  *FMCLOS* - routine to close a meso-nh file opened with the "FM"-routines
6 !!
7 !!    PURPOSE
8 !!    -------
9 !
10 !       The purpose of FMCLOS is to close a mesonh file composed of the DESFM
11 !     and the LFIFM part. The LFIFM file is closed
12 !     using the LFI-package for direct access Fortran files. The DESFM file is
13 !     closed using a classical CLOSE statement.
14 !
15 !!**  METHOD
16 !!    ------
17 !!
18 !!      The closure is proceeded in 4 steps:
19 !!        1. close DESFM
20 !!        2. close LFIFM by calling LFIFER
21 !!        3. erase the file from the management arrays (FMFREE)
22 !!        4. the cpio and storage command is loaded into the pipe
23 !!           the pipe has the special fortran unit 10
24 !!
25 !!    EXTERNAL
26 !!    --------
27 !!
28 !!      FMLOOK,FMFREE,LFIFER,CLOSE,FLUSH,LOCKON,LOCKOFF
29 !!
30 !!    IMPLICIT ARGUMENTS
31 !!    ------------------
32 !!
33 !!      MODULE: MODD_FMDECLAR contains management parameters and
34 !!              storage arrays to move information around at the
35 !!              level of all "FM"-routines.
36 !!              MODD_FMMULTI contains variables for multitasking
37 !!
38 !!    REFERENCE
39 !!    ---------
40 !!
41 !!      see the Technical Specifications Report for the Meso-nh project
42 !!      (in French)
43 !!
44 !!    AUTHOR
45 !!    ------
46 !!
47 !!      C. FISCHER      *METEO-FRANCE*
48 !!
49 !!    MODIFICATIONS
50 !!    -------------
51 !!
52 !!      original                                                        06/94
53 !!      modified by C. Fischer                    4/11/94 (write in the pipe)
54 !!      modified by C. Fischer                5/7/95 (locks for multitasking)
55 !!      modified by P. Jabouille                  26/06/96 (case NFITYP=2 :
56 !!                                     file is not sent to the remote machine)
57 !!      modified by V. Masson               16/09/96 (prints if error occurs)
58 !!
59 !----------------------------------------------------------------------------
60 !
61 !*      0.    DECLARATIONS
62 !             ------------
63 !
64 USE MODD_FMDECLAR
65 USE MODD_FMMULTI
66
67 IMPLICIT NONE
68 !
69 !*      0.1   Declarations of arguments
70 !
71 CHARACTER(LEN=*),     INTENT(IN) ::HFILEM  ! file name
72 CHARACTER(LEN=*),     INTENT(IN) ::HSTATU  ! status for the closed file
73
74 CHARACTER(LEN=*),     INTENT(IN) ::HFIPRI  ! file for prints in FM
75
76 INTEGER,              INTENT(OUT)::KRESP   ! return-code if problems araised
77
78 !
79 !*      0.2   Declarations of local variables
80 !
81 INTEGER::IRESP,IROWF,IPOSNU,J,INUMBR,IFMFNL,ILUPRI,IERR
82 CHARACTER(LEN=7)::YSTATU
83 CHARACTER(LEN=JPFINL)::YFNDES,YFNLFI
84 CHARACTER(LEN=LEN(HFILEM))::YINTFN
85 CHARACTER(LEN=10)::YTRANS,YCPIO
86 CHARACTER(LEN=100)::YCOMMAND
87 LOGICAL::GSTATU
88 !
89 !*      0.3   Taskcommon for logical units
90 !
91 COMMON/TASKCLOS/ILUPRI,INUMBR,IRESP,YFNDES,YFNLFI,YSTATU
92 !DIR$ TASKCOMMON TASKCLOS
93 !
94 !----------------------------------------------------------------------------
95 !
96 !*      1.1   THE NAME OF DESFM=HFILEM.des
97 !
98 IRESP = 0 ; IROWF = 0 ; IPOSNU = 0 ; ILUPRI = 6 ; IERR = 0
99 IFMFNL=JPFINL-4
100 YTRANS='transfer.x'
101
102 IROWF=LEN(HFILEM)
103
104 IF (IROWF.EQ.0) THEN
105    IRESP=-59
106    GOTO 1000
107 ELSEIF (IROWF.GT.IFMFNL) THEN
108    IRESP=-60
109    GOTO 1000
110 ENDIF
111 YINTFN=ADJUSTR(HFILEM)
112 YFNDES=YINTFN//'.des'
113 YFNDES=ADJUSTL(YFNDES)
114 !
115 !*      1.2   TEST FOR FILE EXISTENCE AND SEARCH OF ITS LOGICAL UNIT
116 !
117 CALL FMLOOK(YFNDES,HFIPRI,INUMBR,IRESP)
118 IF (IRESP.NE.0) THEN
119         GOTO 1000
120 ELSEIF (LEN(HSTATU).LE.0) THEN
121         IRESP=-41
122         GOTO 1000
123 ELSE
124         GSTATU=HSTATU.EQ.'KEEP'.OR.HSTATU.EQ.'DELETE'
125         IF (GSTATU) THEN
126         YSTATU=HSTATU(1:MIN0(LEN(HSTATU),LEN(YSTATU)))
127         ELSE
128         YSTATU='DEFAULT'
129         ENDIF
130 ENDIF
131 !
132 !*      1.3   THE LOGICAL UNIT OF DESFM IS RELEASED FOR "FM"
133 !
134 CALL FMFREE(YFNDES,HFIPRI,IRESP)
135 IF (IRESP.NE.0) GOTO 1000
136 !
137 !*      2.    CLOSURE OF DESFM
138 !
139 !  case of a namelist
140 !
141 CLOSE (UNIT=INUMBR,IOSTAT=IRESP,STATUS=YSTATU)
142 IF (IRESP.NE.0) GOTO 1000
143 !
144 !*      3.1   THE NAME OF LFIFM=HFILEM.lfi
145 !
146 YFNLFI=YINTFN//'.lfi'
147 YFNLFI=ADJUSTL(YFNLFI)
148 !
149 !*      3.2   TEST FOR FILE EXISTENCE AND SEARCH OF ITS LOGICAL UNIT
150 !
151 CALL FMLOOK(YFNLFI,HFIPRI,INUMBR,IRESP)
152 IF (IRESP.NE.0) GOTO 1000
153 !
154 !*      3.3   THE LOGICAL UNIT FOR LFIFM IS RELEASED FOR "FM"
155 !
156 CALL FMFREE(YFNLFI,HFIPRI,IRESP)
157 IF (IRESP.NE.0) GOTO 1000
158 !
159 !*      4.    CLOSURE OF LFI
160 !
161 !  case of a LFI file
162 !
163 CALL LFIFER(IRESP,INUMBR,YSTATU)
164 IF (IRESP.NE.0) GOTO 1000
165 !
166 !*      5.    INPUT FOR THE UNIX SYSTEM TO SAVE AND SEND THE FILE
167 !
168 PRINT*,'KTYPE=',NFITYP(INUMBR)
169 SELECT CASE (NFITYP(INUMBR))
170 CASE(:-1)
171   IRESP=-66
172   GOTO 1000
173 CASE(0)
174   YCPIO='NIL'
175 CASE(1)
176   YCPIO='MESONH'
177 CASE(2)
178   PRINT*,'FILE ',HFILEM,' NOT TRANSFERED'
179   GOTO 1000
180 CASE(3:)
181   IRESP=-66
182   GOTO 1000
183 END SELECT
184 WRITE (YCOMMAND,20) YTRANS,YCPIO,HFILEM
185 !
186 ! write into the pipe : the "flush" forces instanteneous buffer transfer
187 ! which is necessary for parallel treatment
188 !
189 PRINT*,'YCOMMAND=',YCOMMAND
190 WRITE (10,'(A100)') YCOMMAND
191 !CALL FLUSH(10,IERR)
192 !
193 !*      6.    UPDATING OF ARRAY NFITYP
194 !
195 IF (LFMMUL) CALL LOCKON(NFMLOC)
196 NFITYP(INUMBR)=JPNIIL
197 IF (LFMMUL) CALL LOCKOFF(NFMLOC)
198 !
199 !*      7.    MESSAGE PRINTING WHATEVER THE ISSUE WAS
200 !
201 1000    CONTINUE
202
203 IF (IRESP.NE.0) THEN
204 YFNLFI=ADJUSTL(HFIPRI)
205 DO J=1,JPNXLU
206     IF (CNAMFI(J).EQ.YFNLFI) THEN
207        ILUPRI=J
208        EXIT
209     ENDIF
210 ENDDO
211 WRITE (ILUPRI,*) ' exit from FMCLOS with IRESP:',IRESP
212 WRITE (ILUPRI,*) '   | HFILEM = ',HFILEM
213 WRITE (ILUPRI,*) '   | HSTATU = ',HSTATU
214 ENDIF
215 KRESP=IRESP
216
217 ! format: 10c for transfer.x and mesonh/nil
218 !         32c for file name
219 ! if you have to change this format one day, don't forget the blank after 1H
220 20    FORMAT(A10,1H ,A10,1H ,A32)
221
222 RETURN
223       END SUBROUTINE FMCLOS