Philippe 02/05/2016: moved all LIBTOOLS files in LIBTOOLS directory
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / DIAPRO / colvect.f90
1 !     ##############################
2       SUBROUTINE COLVECT(KKU,PTEM2D)
3 !     ##############################
4 !
5 !!****  *COLVECT* -  Couleur fleches par un autre parametre
6 !! Possible uniquement pour les profils verticaux de vecteurs vent horizontal
7 !! generes directement ds un fichier diachronique (CART + MASK)
8 !!****           
9 !!
10 !!    PURPOSE
11 !!    -------
12 !       
13 !      
14 !     
15 !
16 !!**  METHOD
17 !!    ------
18 !!    
19 !!   
20 !!
21 !!    EXTERNAL
22 !!    --------
23 !!      
24 !!     
25 !!
26 !!    IMPLICIT ARGUMENTS
27 !!    ------------------
28 !!      Module MODN_PARA  : Defines NAM_DOMAIN_POS namelist (former PARA common)
29 !!         NLANGLE :  Angle between X Meso-NH axis and
30 !!                    cross-section direction in degrees
31 !!                    (Integer value anticlockwise)
32 !!
33 !!    REFERENCE
34 !!    ---------
35 !!
36 !!      MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
37 !!       + Book1: Concepts and Fundamentals, to appear in 1994;
38 !!       + Book2: Technical Reference and Flowcharts, to appear in 1994;
39 !!       + Book3: Tutorial, November 1994.
40 !!
41 !!
42 !!    AUTHOR
43 !!    ------
44 !!      J. Duron    * Laboratoire d'Aerologie *
45 !!
46 !!    MODIFICATIONS
47 !!    -------------
48 !!      Original       23/10/2001
49 !!      Updated   
50 !-------------------------------------------------------------------------------
51 !
52 !*       0.    DECLARATIONS
53 !              ------------
54 !
55 USE MODN_NCAR
56 USE MODD_PVT
57 USE MODD_RESOLVCAR
58 !
59 IMPLICIT NONE
60 !
61 !*       0.1  Dummy arguments and results
62 !
63                                               ! 
64                                               !
65 REAL, DIMENSION(:,:),  INTENT(IN) :: PTEM2D !
66                                               !
67 INTEGER   :: KKU                              !
68                                               ! 
69 !
70 !*       0.2  Local variables
71 !
72 INTEGER             :: JILOOP, JJLOOP, JKLOOP
73 !
74 REAL                :: ZMXPARCOL, ZMNPARCOL, ZINTPARCOL
75 !
76 !-------------------------------------------------------------------------------
77 !
78 !*        1.   COMPUTING THE LONGITUDINAL AND TRANSVERSE COMPONENTS
79 !              ----------------------------------------------------
80 !
81 !*        1.1  
82 !
83 IF(ALLOCATED(NCOL2DUV))THEN
84   DEALLOCATE(NCOL2DUV)
85 ENDIF
86 ALLOCATE(NCOL2DUV(SIZE(PTEM2D,2),KKU))
87 LCOLPVT=.TRUE.
88 NCOL2DUV=1
89 IF(LCOLUSERUV)THEN !:::::::::::::::::::::::::::
90   DO JILOOP=1,SIZE(PTEM2D,1)
91   DO JJLOOP=1,SIZE(PTEM2D,2)
92
93   IF(PTEM2D(JILOOP,JJLOOP) /= XSPVAL)THEN
94   IF(PTEM2D(JILOOP,JJLOOP) < XPARCOLUV(1))THEN
95     NCOL2DUV(JJLOOP,JILOOP)=NINDCOLUV(1)
96   ELSE IF(PTEM2D(JILOOP,JJLOOP) >= XPARCOLUV&
97   (NBPARCOLUV))THEN
98     NCOL2DUV(JJLOOP,JILOOP)=NINDCOLUV(NBCOLUV)
99   ELSE
100     DO JKLOOP=2,NBPARCOLUV
101        IF(PTEM2D(JILOOP,JJLOOP) >= XPARCOLUV(&
102        JKLOOP-1) .AND. PTEM2D(JILOOP,JJLOOP)<&
103         XPARCOLUV(JKLOOP))then
104          NCOL2DUV(JJLOOP,JILOOP)=NINDCOLUV(&
105          JKLOOP)
106          EXIT
107        ENDIF
108     ENDDO
109   ENDIF
110 ENDIF
111
112 ENDDO
113 ENDDO
114       ELSE               !:::::::::::::::::::::::::::
115 ZMXPARCOL=-1.e14
116 ZMNPARCOL=+1.e14
117 DO JILOOP=1,SIZE(PTEM2D,1)
118 DO JJLOOP=1,SIZE(PTEM2D,2)
119                             
120   IF(PTEM2D(JILOOP,JJLOOP) /= XSPVAL)THEN
121     ZMXPARCOL=MAX(PTEM2D(JILOOP,JJLOOP),ZMXPARCOL)
122     ZMNPARCOL=MIN(PTEM2D(JILOOP,JJLOOP),ZMNPARCOL)
123   ENDIF
124 ENDDO
125 ENDDO
126 IF(ABS(ZMXPARCOL-ZMNPARCOL) >= 20)THEN
127  ZMNPARCOL=ZMNPARCOL+1
128  ZMXPARCOl=ZMXPARCOl-1
129 ENDIF
130 ZINTPARCOL=(ZMXPARCOL-ZMNPARCOL)/5.
131 XPARCOLUVSTD(1)=ZMNPARCOL
132 DO JILOOP=2,NBPARCOLUVSTD-1
133   XPARCOLUVSTD(JILOOP)=XPARCOLUVSTD(JILOOP-1)+&
134   ZINTPARCOL
135 ENDDO
136 XPARCOLUVSTD(NBPARCOLUVSTD)=ZMXPARCOL
137 if(nverbia > 0)then
138 print *,' **OPER_UV** XPARCOLUVSTD ',XPARCOLUVSTD
139 endif
140 DO JILOOP=1,SIZE(PTEM2D,1)
141 DO JJLOOP=1,SIZE(PTEM2D,2)
142
143 IF(PTEM2D(JILOOP,JJLOOP) /= XSPVAL)THEN
144   IF(PTEM2D(JILOOP,JJLOOP) < XPARCOLUVSTD(1))THEN
145     NCOL2DUV(JJLOOP,JILOOP)=NCOLUVSTD(1)
146   ELSE IF(PTEM2D(JILOOP,JJLOOP) >= XPARCOLUVSTD&
147   (NBPARCOLUVSTD))THEN
148     NCOL2DUV(JJLOOP,JILOOP)=NCOLUVSTD(NBCOLUVSTD)
149   ELSE
150     DO JKLOOP=2,NBPARCOLUVSTD
151        IF(PTEM2D(JILOOP,JJLOOP) >= XPARCOLUVSTD(&
152        JKLOOP-1) .AND. PTEM2D(JILOOP,JJLOOP)<&
153         XPARCOLUVSTD(JKLOOP))then
154          NCOL2DUV(JJLOOP,JILOOP)=NCOLUVSTD(&
155          JKLOOP)
156          EXIT
157        ENDIF
158     ENDDO
159   ENDIF
160 ENDIF
161
162
163 ENDDO
164 ENDDO
165
166       ENDIF             !::::::::::::::::::::::::::::::::::
167 !
168 !*        1.2  
169 !*            
170 !*           
171 !*          
172 !
173 !
174 !*       1.3   
175 !
176 IF(nverbia > 0)THEN
177  print *,' ** colvect '
178 endif
179 !
180 !------------------------------------------------------------------------------
181 !
182 !*        2.     EXIT
183 !                ----
184 !
185 RETURN
186 END SUBROUTINE COLVECT