Philippe 23/02/2016: lfi2cdf: modif for JPHEXT/=1
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / mesonh_MOD / mode_gridcart.f90
1 !-----------------------------------------------------------------
2 !--------------- special set of characters for SCCS information
3 !--------------- C. Fischer 30/09/94
4 !      @(#) Lib:/opt/local/MESONH/sources/mode/s.mode_gridcart.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
5 !-----------------------------------------------------------------
6 !     ####################
7       MODULE MODE_GRIDCART
8 !     ####################
9 !
10 !!****  *MODE_GRIDCART* -  module routine SM_GRIDCART 
11 !!
12 !!    PURPOSE
13 !!    -------
14 !       The purpose of this executive module  is to package 
15 !     the routine SM_GRIDCART 
16 !    
17 !      
18 !
19 !!
20 !!**  IMPLICIT ARGUMENTS
21 !!    ------------------
22 !!       NONE          
23 !!
24 !!    REFERENCE
25 !!    ---------
26 !!
27 !!
28 !!    AUTHOR
29 !!    ------
30 !!      V. Ducrocq       * Meteo France *
31 !!
32 !!    MODIFICATIONS
33 !!    -------------
34 !!      Original    06/05/94 
35 !--------------------------------------------------------------------------------
36 !
37 !*       0.    DECLARATIONS
38 !              ------------
39 !
40 !-------------------------------------------------------------------------------
41 !
42 CONTAINS
43 !-------------------------------------------------------------------------------
44 !-------------------------------------------------------------------------------
45 !
46 !*       1.   ROUTINE SM_GRIDCART
47 !             -------------------
48 !-------------------------------------------------------------------------------
49 !     #########################################################################
50       SUBROUTINE SM_GRIDCART(HLUOUT,PXHAT,PYHAT,PZHAT,PZS,OSLEVE,PLEN1,PLEN2,PZSMT,PDXHAT,PDYHAT,PZZ,PJ)
51 !     #########################################################################
52 !
53 !!****  *SM_GRIDCART * - routine to compute J 
54 !!
55 !!    PURPOSE
56 !!    -------
57 !       The purpose of this routine is to compute the Jacobian (J) in the case
58 !     of a cartesian geometry 
59 !      
60 !
61 !!**  METHOD
62 !!    ------
63 !!       The height z is first determined, and then J is computed 
64 !!     
65 !!
66 !!    EXTERNAL
67 !!    --------
68 !!      NONE
69 !!
70 !!    IMPLICIT ARGUMENTS
71 !!    ------------------
72 !!      Module MODD_PARAMETERS : contains array border depths
73 !! 
74 !!        JPHEXT,JPVEXT : Arrays border zone depth
75 !!
76 !!      Module MODD_CONF       : contains  configuration variables for 
77 !!                               all models
78 !
79 !!        NVERB        : Listing verbosity
80 !!
81 !!    REFERENCE
82 !!    ---------
83 !!      Technical Specifications Report of the Meso-NH project (chapters 2 and 3)
84 !!
85 !!
86 !!    AUTHOR
87 !!    ------
88 !!      V. Ducrocq       * Meteo France *
89 !!
90 !!    MODIFICATIONS
91 !!    -------------
92 !!      Original    06/05/94 
93 !!      updated                 V. Ducrocq  *Meteo France*   27/06/94 
94 !!      Updated                 P.M.        *LA*             22/07/94
95 !!      Updated                 V. Ducrocq  *Meteo France*   23/08/94 
96 !-------------------------------------------------------------------------------
97 !
98 !*       0.    DECLARATIONS
99 !              ------------
100 !
101 USE MODD_PARAMETERS       
102 USE MODD_CONF
103 !
104 USE MODI_VERT_COORD
105 !
106 IMPLICIT NONE
107 !
108 !*       0.1   Declarations of arguments
109 !
110 CHARACTER(LEN=*),       INTENT(IN)  :: HLUOUT            ! Output-listing name 
111 REAL, DIMENSION(:),     INTENT(IN)  :: PXHAT,PYHAT,PZHAT ! positions x,y,z in 
112                                                          ! the cartesian plane
113 REAL, DIMENSION(:,:),   INTENT(IN)  :: PZS               ! orography
114 LOGICAL,                INTENT(IN)  :: OSLEVE            ! flag for SLEVE coordinate
115 REAL,                   INTENT(IN)  :: PLEN1             ! Decay scale for smooth topography
116 REAL,                   INTENT(IN)  :: PLEN2             ! Decay scale for small-scale topography deviation
117 REAL, DIMENSION(:,:),   INTENT(IN)  :: PZSMT             ! smooth orography
118 !
119 REAL, DIMENSION(:),     INTENT(OUT) :: PDXHAT            ! meshlength in x 
120                                                          ! direction
121 REAL, DIMENSION(:),     INTENT(OUT) :: PDYHAT            ! meshlength in y 
122                                                          ! direction 
123 REAL, DIMENSION(:,:,:), INTENT(OUT) :: PZZ               ! Height z
124 REAL, DIMENSION(:,:,:), INTENT(OUT) :: PJ                ! Jacobian of the
125                                                          ! GCS transformation
126 !
127 !*       0.2   Declarations of local variables
128 !
129 REAL, DIMENSION(SIZE(PXHAT,1),SIZE(PYHAT,1),SIZE(PZHAT,1)) :: ZDZ ! meshlength in
130                                                                   ! z direction 
131 REAL, DIMENSION(SIZE(PZS,1),SIZE(PZS,2)) :: ZBOUNDZ          ! Extrapolated
132 REAL                                     :: ZBOUNDX,ZBOUNDY  ! value for the 
133                                                              ! upper bounds in 
134                                                              ! z,x,y directions  
135 !
136 INTEGER      :: IIB,IJB,IKB      ! beginning of useful area of PXHAT,PYHAT,PZHAT  
137 INTEGER      :: IIE,IJE,IKE      ! end of useful area of PXHAT,PYHAT,PZHAT  
138 INTEGER      :: IIU,IJU,IKU      ! upper bounds of PXHAT,PYHAT,PZHAT  
139 INTEGER      :: IKLOOP           ! index for prints
140 INTEGER      :: ILUOUT,IRESP     ! logical unit number for prints, error code
141 !
142 !-------------------------------------------------------------------------------
143 !
144 !*       1    RETRIEVE LOGICAL UNIT NUMBERFOR OUTPUT-LISTING AND  DIMENSIONS 
145 !             --------------------------------------------------------------
146 !
147 CALL FMLOOK(HLUOUT,HLUOUT,ILUOUT,IRESP)
148 !
149 IIU = UBOUND(PXHAT,1)         
150 IJU = UBOUND(PYHAT,1)        
151 IKU = UBOUND(PZHAT,1)          
152 IIE = IIU-JPHEXT
153 IJE = IJU-JPHEXT
154 IKE = IKU-JPVEXT
155 IIB = 1+JPHEXT
156 IJB = 1+JPHEXT
157 IKB = 1+JPVEXT
158 !
159 IF(NVERB >= 10) THEN                         ! Parameter checking
160   WRITE(ILUOUT,*) 'SM_GRIDCART: IIU,IJU,IKU=',IIU,IJU,IKU
161   WRITE(ILUOUT,*) 'SM_GRIDCART: IIE,IJE,IKE=',IIE,IJE,IKE
162   WRITE(ILUOUT,*) 'SM_GRIDCART: IIB,IJB,IKB=',IIB,IJB,IKB
163 ENDIF
164 !
165 !-------------------------------------------------------------------------------
166 !
167 !*       2.    COMPUTE Z
168 !              ---------
169 !
170 CALL VERT_COORD(OSLEVE,PZS,PZSMT,PLEN1,PLEN2,PZHAT,PZZ)
171 !
172 IF(NVERB >= 10) THEN                               !Value control
173   WRITE(ILUOUT,*) 'SM_GRIDCART: Some PZS values:'
174   WRITE(ILUOUT,*)  PZS(1,1),PZS(IIU/2,IJU/2),PZS(IIU,IJU)  
175   WRITE(ILUOUT,*) 'SM_GRIDCART: Some PZZ values:'
176   DO IKLOOP=1,IKU
177     WRITE(ILUOUT,*) PZZ(1,1,IKLOOP),PZZ(IIU/2,IJU/2,IKLOOP), &
178                     PZZ(IIU,IJU,IKLOOP)  
179   END DO
180 ENDIF
181 !-------------------------------------------------------------------------------
182 !
183 !
184 !*       3.    COMPUTE J
185 !              ---------
186 !
187 ZBOUNDX      = 2.*PXHAT(IIU)   - PXHAT(IIU-1)
188 ZBOUNDY      = 2.*PYHAT(IJU)   - PYHAT(IJU-1)
189 ZBOUNDZ(:,:) = 2.*PZZ(:,:,IKU) - PZZ(:,:,IKU-1)
190 PDXHAT(:)  = EOSHIFT(PXHAT(:) ,1,ZBOUNDX)      - PXHAT(:)
191 PDYHAT(:)  = EOSHIFT(PYHAT(:) ,1,ZBOUNDY)      - PYHAT(:)
192 ZDZ(:,:,:) = EOSHIFT(PZZ(:,:,:),1,ZBOUNDZ(:,:),3) - PZZ(:,:,:)
193 PJ(:,:,:)  = SPREAD((SPREAD(PDXHAT(:),2,IJU) * SPREAD(PDYHAT(:),1,IIU)),3,IKU)  &
194            * ZDZ(:,:,:) 
195 !
196 IF(NVERB >= 10) THEN                               !Value control
197   WRITE(ILUOUT,*) 'Some PJ values:'
198   DO IKLOOP=1,IKU
199     WRITE(ILUOUT,*) PJ(1,1,IKLOOP),PJ(IIU/2,IJU/2,IKLOOP),  &
200                     PJ(IIU,IJU,IKLOOP)  
201   END DO
202 ENDIF
203
204 !-------------------------------------------------------------------------------
205 !
206 END SUBROUTINE SM_GRIDCART
207 !-------------------------------------------------------------------------------
208 END MODULE MODE_GRIDCART