Philippe 23/02/2016: lfi2cdf: modif for JPHEXT/=1
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / FM / fm_read.f90
1 !     ######spl
2       SUBROUTINE FM_READ(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
3                         KLENCH,HCOMMENT,KRESP)
4 !     ###########################################################
5 !
6 !!****  *FM_READ* - routine to read a single data article in a "FM"-file
7 !!
8 !!    PURPOSE
9 !!    -------
10 !
11 !       The purpose of FMREAD is to read one single article of data in
12 !     a Meso-nh file. This routine only holds for LFI-files (not namelists)
13 !
14 !!**  METHOD
15 !!    ------
16 !!
17 !!      The unformatted fortran read operation is actually executed in the
18 !!    routine LFILEC. You just need to indicate the name of the file
19 !!    without the ".lfi" suffix,
20 !!    and the name of the article you want to read, as well as the length of
21 !!    the field. LFILEC then knows how
22 !!    to get the record number of the desired field by referring to an intern
23 !!    table of association.
24 !!      In FMREAD, the data is first stored in IWORK and then split in KGRID
25 !!    (IWORK(1)=C-grid indicator) and KFIELD (integer or real data field)
26 !!    which are both stored on the same LFI logical article.
27 !!
28 !!    EXTERNAL
29 !!    --------
30 !!
31 !!      FMLOOK,LFINFO,LFILEC,CHAR
32 !!
33 !!    IMPLICIT ARGUMENTS
34 !!    ------------------
35 !!
36 !!      MODULE: MODD_FMDECLAR contains management parameters and
37 !!              storage arrays to move information around at the
38 !!              level of all "FM"-routines.
39 !!
40 !!    REFERENCE
41 !!    ---------
42 !!
43 !!      see the Technical Specifications Report for the Meso-nh project
44 !!      (in French)
45 !!
46 !!    AUTHOR
47 !!    ------
48 !!
49 !!      C. FISCHER      *METEO-FRANCE*
50 !!
51 !!    MODIFICATIONS
52 !!    -------------
53 !!
54 !!      original                                                        06/94
55 !!      modified by V. Masson               16/09/96 (prints if error occurs)
56 !!
57 !----------------------------------------------------------------------------
58 !
59 !*      0.    DECLARATIONS
60 !             ------------
61 !
62 USE MODD_FMDECLAR
63
64 IMPLICIT NONE
65 !
66 !*      0.1   Declarations of arguments
67 !
68 CHARACTER(LEN=*),          INTENT(IN) ::HFILEM ! file name
69 CHARACTER(LEN=*),          INTENT(IN) ::HRECFM ! name of the desired article
70
71 CHARACTER(LEN=*),          INTENT(IN) ::HFIPRI ! file for prints in FM
72
73 INTEGER,                   INTENT(IN) ::KLENG  ! length of the data field
74
75 INTEGER(KIND=8),DIMENSION(1:KLENG),INTENT(OUT)::KFIELD ! array containing 
76                                                         ! the data field
77 INTEGER,                   INTENT(OUT)::KGRID  ! C-grid indicator (u,v,w,T)
78 INTEGER,                   INTENT(OUT)::KLENCH ! length of comment string
79
80 CHARACTER(LEN=JPXKRK),     INTENT(OUT)::HCOMMENT ! comment string
81
82 INTEGER,                   INTENT(OUT)::KRESP  ! return-code if problems occured
83
84 !
85 !*      0.2   Declarations of local variables
86 !
87 INTEGER::IRESP,ILENGA,IPOSEX,ITOTAL,INUMBR,J,IROW,IFMFNL,ILUPRI
88 INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE::IWORK,IWORKNEW
89 INTEGER,DIMENSION(1:JPXKRK)::ICOMMENT
90 CHARACTER(LEN=JPFINL)::YFNLFI
91 CHARACTER(LEN=LEN(HFILEM))::YINTFN
92 INTEGER :: DATASIZE,ITYPCOD,NEWSIZE
93 !
94 !*      0.3   Taskcommon for logical units
95 !
96 COMMON/TASKREAD/ILUPRI,INUMBR,IRESP
97 !DIR$ TASKCOMMON TASKREAD
98 !
99 !----------------------------------------------------------------------------
100 !
101 !*      1.1   THE NAME OF LFIFM
102 !
103 IRESP = 0 ; IROW = 0 ; ILUPRI = 6
104 IFMFNL=JPFINL-4
105
106 IROW=LEN(HFILEM)
107
108 IF (IROW.EQ.0) THEN
109    IRESP=-61
110    GOTO 1000
111 ELSEIF (IROW.GT.IFMFNL) THEN
112    IRESP=-62
113    GOTO 1000
114 ENDIF
115 YINTFN=ADJUSTR(HFILEM)
116 YFNLFI=YINTFN//'.lfi'
117 YFNLFI=ADJUSTL(YFNLFI)
118
119 !
120 !*      1.2   WE LOOK FOR THE FILE'S LOGICAL UNIT
121 !
122 CALL FMLOOK(YFNLFI,HFIPRI,INUMBR,IRESP)
123 IF (IRESP.NE.0) GOTO 1000
124
125 !
126 !*      2.a   LET'S GET SOME INFORMATION ON THE DESIRED ARTICLE
127 !
128 !ILENGA=0
129 !print *,' ***FM_READ ILENGA mis a 0 avant CALL LFINFO'
130 CALL LFINFO(IRESP,INUMBR,HRECFM,ILENGA,IPOSEX)
131 !print *,' ***FM_READ ILENGA,IRESP AP LFINFO ',ILENGA,IRESP
132 IF (IRESP.NE.0) THEN
133         GOTO 1000
134 ELSEIF (ILENGA.EQ.0) THEN
135 !print *,' ***FM_READ passage IRESP=-47 GOTO 1000'
136         IRESP=-47
137         GOTO 1000
138 ELSEIF (ILENGA.GT.JPXFIE) THEN
139         IRESP=-48
140         GOTO 1000
141 ENDIF
142
143 !
144 !*      2.b   UNFORMATTED DIRECT ACCESS READ OPERATION
145 !
146 ITOTAL=ILENGA
147 IF(ALLOCATED(IWORK)) DEALLOCATE(IWORK)
148 ALLOCATE(IWORK(ITOTAL))
149
150 CALL LFILEC(IRESP,INUMBR,HRECFM,IWORK,ITOTAL)
151 IF (IRESP.NE.0) GOTO 1000
152 !
153 !*      2.c   THE GRID INDICATOR AND THE COMMENT STRING
154 !*            ARE SEPARATED FROM THE DATA
155 !
156 KGRID=IWORK(1)
157 KLENCH=IWORK(2)
158 IF (KLENCH < 0 .OR. KLENCH > JPXKRK) THEN
159   IRESP=-58
160   GOTO 1000
161 END IF
162 !
163 DATASIZE=ITOTAL-KLENCH-2
164 !
165 CALL GET_COMPHEADER(IWORK(3+KLENCH),DATASIZE,NEWSIZE,ITYPCOD)
166 IF (NEWSIZE >= 0) THEN
167   ! compressed field found
168   WRITE (ILUPRI,*) TRIM(HRECFM),' is compressed (old/new/kleng SIZE):',DATASIZE,NEWSIZE,KLENG 
169   IF (KLENG /= NEWSIZE) THEN
170     IRESP=-63
171     GOTO 1000
172   ENDIF
173
174   ALLOCATE(IWORKNEW(NEWSIZE))
175   CALL DECOMPRESS_FIELD(IWORKNEW,NEWSIZE,IWORK(3+KLENCH),DATASIZE,ITYPCOD)
176   KFIELD(1:KLENG) = IWORKNEW(1:KLENG)
177   DEALLOCATE(IWORKNEW)
178 ELSE
179   IF (KLENG /= DATASIZE) THEN
180     IRESP=-63
181     GOTO 1000
182   END IF
183   KFIELD(1:KLENG)=IWORK(KLENCH+3:ITOTAL)
184 END IF
185 !
186 SELECT CASE (KLENCH)
187 CASE(-10:-1)
188        IRESP=-58
189        GOTO 1000
190 CASE(0)
191        KFIELD(1:KLENG)=IWORK(3:ITOTAL)
192 CASE(1:JPXKRK)
193        ICOMMENT(1:KLENCH)=IWORK(3:KLENCH+2)
194        DO J=1,KLENCH
195           HCOMMENT(J:J)=CHAR(ICOMMENT(J))
196        ENDDO
197 CASE(JPXKRK+1:)
198        IRESP=-56
199        GOTO 1000
200 END SELECT
201 !
202 DEALLOCATE(IWORK)
203 !
204 !  this is a pure binary field: no uncompressing of any kind
205 !
206 !*      3.    MESSAGE PRINTING WHATEVER THE ISSUE WAS
207 !
208 1000    CONTINUE
209
210 IF (IRESP.NE.0) THEN
211   YFNLFI=ADJUSTL(HFIPRI)
212   DO J=1,JPNXLU
213     IF (CNAMFI(J).EQ.YFNLFI) THEN
214       ILUPRI=J
215       EXIT
216     ENDIF
217   ENDDO
218   WRITE (ILUPRI,*) ' exit from FMREAD with IRESP:',IRESP
219   !WRITE (ILUPRI,*) '   | HFILEM = ',HFILEM
220   WRITE (ILUPRI,*) '   | HRECFM = ',HRECFM
221   !WRITE (ILUPRI,*) '   | KLENG  = ',KLENG
222   !WRITE (ILUPRI,*) '   | KGRID  = ',KGRID
223   !WRITE (ILUPRI,*) '   | KLENCH  = ',KLENCH
224   ! Suppression OBLIGATOIRE de l'impression suivante car pb qd IWORK non alloue
225   ! (IRESP=-47)
226   !WRITE (ILUPRI,*) '   | KLENCH  = ',IWORK(23)
227 ENDIF
228 KRESP=IRESP
229
230 RETURN
231       END SUBROUTINE FM_READ