Philippe 01/12/2015: added missing & at the beginning of output message lines
[MNH-git_open_source-lfs.git] / src / MNH / mnhopen_aux_io_surf.f90
1 !MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
2 !MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
3 !MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
4 !MNH_LIC for details. version 1.
5 !     #########################
6       MODULE MODI_MNHOPEN_AUX_IO_SURF
7 !     #########################
8 INTERFACE
9       SUBROUTINE MNHOPEN_AUX_IO_SURF(HFILE,HFILETYPE,HMASK)
10 !
11 CHARACTER(LEN=28), INTENT(IN)  :: HFILE     ! file name
12 CHARACTER(LEN=6),  INTENT(IN)  :: HFILETYPE ! main program
13 CHARACTER(LEN=6),  INTENT(IN)  :: HMASK
14 !
15 END SUBROUTINE MNHOPEN_AUX_IO_SURF
16 !
17 END INTERFACE
18 END MODULE MODI_MNHOPEN_AUX_IO_SURF
19 !
20 !     #######################################################
21       SUBROUTINE MNHOPEN_AUX_IO_SURF(HFILE,HFILETYPE,HMASK)
22 !     #######################################################
23 !
24 !!****  *MNHOPEN_AUX_IO_SURF* - routine to open surface IO files (MESONH universe)
25 !!
26 !!    PURPOSE
27 !!    -------
28 !!
29 !!**  METHOD
30 !!    ------
31 !!
32 !!    EXTERNAL
33 !!    --------
34 !!
35 !!
36 !!    IMPLICIT ARGUMENTS
37 !!    ------------------
38 !!
39 !!    REFERENCE
40 !!    ---------
41 !!
42 !!
43 !!    AUTHOR
44 !!    ------
45 !!      S.Malardel   *Meteo France*     
46 !!
47 !!    MODIFICATIONS
48 !!    -------------
49 !!      Original    09/2003 
50 !!         M.Moge   04/2015  parallelization og PREP_PGD on son model
51 !!   J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 
52 !-------------------------------------------------------------------------------
53 !
54 !*       0.    DECLARATIONS
55 !              ------------
56 !
57 !
58 USE MODD_IO_SURF_MNH, ONLY : COUT, CFILE, COUTFILE, NLUOUT, &
59          NMASK_ALL, CMASK, NIU_ALL, NJU_ALL, NIB_ALL, NJB_ALL, NIE_ALL, NJE_ALL, CACTION, &
60          NMASK, NIU, NJU, NIB, NJB, NIE, NJE
61 !
62 USE MODD_CONF,           ONLY : CPROGRAM
63 USE MODD_PARAMETERS,     ONLY : JPHEXT
64 USE MODD_LUNIT,          ONLY : CLUOUT0, COUTFMFILE, CPGDFILE
65 !
66 USE MODE_FM
67 USE MODE_FMREAD
68 USE MODE_IO_ll
69 !
70 USE MODI_GET_1D_MASK
71 USE MODI_MNH_SURF_GRID_IO_INIT
72 !
73 IMPLICIT NONE
74 !
75 !*       0.1   Declarations of arguments
76 !              -------------------------
77 !
78 CHARACTER(LEN=28), INTENT(IN)  :: HFILE     ! file name
79 CHARACTER(LEN=6),  INTENT(IN)  :: HFILETYPE ! main program
80 CHARACTER(LEN=6),  INTENT(IN)  :: HMASK
81 !
82 !*       0.2   Declarations of local variables
83 !              -------------------------------
84 !
85 INTEGER           :: IRESP,ININAR   ! IRESP  : return-code if a problem appears 
86                                     ! at the open of the file in LFI  routines 
87 INTEGER           :: IMI            ! model index
88 INTEGER           :: IGRID          ! IGRID : grid indicator
89 INTEGER           :: ILENCH         ! ILENCH : length of comment string
90 CHARACTER(LEN=100):: YCOMMENT       ! Comment string
91 INTEGER           :: IIMAX          ! number of points in X direction
92 INTEGER           :: IJMAX          ! number of points in Y direction
93 !
94 !
95 INTEGER           :: ILU            ! 1D physical dimension of XCOVER
96 REAL, DIMENSION(:),   ALLOCATABLE :: ZFULL  ! total cover
97 INTEGER           :: IJPHEXT
98 !-------------------------------------------------------------------------------
99 !-------------------------------------------------------------------------------
100 ! WARNING : this routine works only on ONE processor jobs
101 !-------------------------------------------------------------------------------
102 !-------------------------------------------------------------------------------
103 !
104 !*       1.    initialization of output listing name
105 !
106 SELECT CASE(CPROGRAM)
107   CASE('MESONH','SPAWN ')
108     CALL GET_MODEL_NUMBER_ll  (IMI)
109     WRITE(COUT,FMT='(A14,I1,A13)') 'OUTPUT_LISTING',IMI,'            '
110   CASE DEFAULT
111     COUT = CLUOUT0
112 END SELECT
113 !
114 CALL FMLOOK_ll(COUT,COUT,NLUOUT,IRESP)
115 !
116 !
117 !*       2.    initialization of surface file
118 !
119 IF (LEN_TRIM(CACTION)>0) THEN
120   WRITE(NLUOUT,*) 'file ',HFILE,' cannot be opened because another MESONH file is in use'
121 END IF
122 !
123 IF (HFILE/=COUTFMFILE .AND. HFILE/=CPGDFILE) THEN
124   CALL FMOPEN_ll(HFILE,'READ',COUT,0,2,5,ININAR,IRESP)
125   CACTION = 'OPEN  '
126 END IF
127 !
128 CFILE    = HFILE
129 COUTFILE = HFILE
130 !
131 !
132 !*       3.    initialisation of 2D arrays for entire physical field
133
134 CALL FMREAD(HFILE,'IMAX',COUT,'--',IIMAX,IGRID,ILENCH,YCOMMENT,IRESP)
135 CALL FMREAD(HFILE,'JMAX',COUT,'--',IJMAX,IGRID,ILENCH,YCOMMENT,IRESP)
136 CALL MNH_SURF_GRID_IO_INIT(IIMAX,IJMAX)
137 IJPHEXT= 1
138 CALL FMREAD(HFILE,'JPHEXT',COUT,'--',IJPHEXT,IGRID,ILENCH,YCOMMENT,IRESP)
139 IF ( IJPHEXT .NE. JPHEXT ) THEN
140    WRITE(NLUOUT,FMT=*) ' MNHOPEN_AUX_IO : JPHEXT in PRE_PGD1.nam/NAM_CONF_PGD ( or default value )&
141       & JPHEXT=',JPHEXT
142    WRITE(NLUOUT,FMT=*) ' different from PGD files=',HFILE ,' value JPHEXT=',IJPHEXT
143    WRITE(NLUOUT,FMT=*) '-> JOB ABORTED'
144    CALL CLOSE_ll(COUT,IOSTAT=IRESP)
145    CALL ABORT  
146    STOP   
147 END IF
148 !
149 NIU_ALL = (IIMAX+2*JPHEXT)
150 NJU_ALL = (IJMAX+2*JPHEXT)
151 NIB_ALL = 1 + JPHEXT
152 NJB_ALL = 1 + JPHEXT
153 NIE_ALL = IIMAX + JPHEXT
154 NJE_ALL = IJMAX + JPHEXT
155 !
156 !*       4.    initialisation 1D physical dimension and mask for entire physical field
157
158 ILU = (NIE_ALL-NIB_ALL+1)*(NJE_ALL-NJB_ALL+1)
159 !
160 CMASK=HMASK
161 !
162 !IF (HMASK=='FULL  ') THEN
163   ALLOCATE(ZFULL(ILU))
164   ZFULL=1.
165   ALLOCATE(NMASK_ALL(ILU))
166   CALL GET_1D_MASK(ILU,ILU,ZFULL,NMASK_ALL)
167   DEALLOCATE(ZFULL)
168 !ELSE
169 !  WRITE(NLUOUT,*) 'mask "',HMASK,'" for reading not supported for auxilliary MESONH file'
170 !END IF
171 !
172 !
173 !*       5.    initialisation of 2D arrays for current processor
174 !
175     CALL GET_DIM_EXT_ll('B',NIU,NJU)
176     CALL GET_INDICE_ll (NIB,NJB,NIE,NJE)
177 !
178 !
179 !*       6.    initialisation 1D physical dimension and mask for current processor
180
181 ILU = (NIE-NIB+1)*(NJE-NJB+1)
182 ALLOCATE(ZFULL(ILU))
183 ZFULL=1.
184 ALLOCATE(NMASK(ILU))
185 CALL GET_1D_MASK(ILU,ILU,ZFULL,NMASK)
186 DEALLOCATE(ZFULL)
187 !
188 !-------------------------------------------------------------------------------
189 !
190 END SUBROUTINE MNHOPEN_AUX_IO_SURF