Commit 5ad4daf13d928c202a204a3d1009a45c1f318db3

Authored by caveenj
1 parent 72b4be49
Exists in master

On bascule la brache de developpement de la pre_v2_0 sur le tronc avant de lui ajouter un TAG v2_0

Showing 4 changed files with 471 additions and 195 deletions   Show diff stats
Makefile
... ... @@ -25,8 +25,8 @@ MY_EXTFCNS = /home/caveenj/projets/ferret_compnc/ferret_ef
25 25  
26 26 FER_LOCAL_EXTFCNS = $(MY_EXTFCNS)
27 27  
28   -FFLAGS_DEBUG = -g
29   -CFLAGS_DEBUG = -g
  28 +FFLAGS_DEBUG = -g -DDEBUG
  29 +CFLAGS_DEBUG = -g -DDEBUG
30 30  
31 31 include ../ef_utility/platform_specific_flags.mk.$(HOSTTYPE)
32 32  
... ... @@ -50,7 +50,7 @@ include ../ef_utility/platform_specific_flags.mk.$(HOSTTYPE)
50 50 # Targets
51 51 #
52 52  
53   -all: ferret_cmn nc_rar.so
  53 +all: ferret_cmn nc_rar.so rom_flip.so
54 54  
55 55 debug:
56 56 $(MAKE) "FFLAGS = $(FFLAGS) $(FFLAGS_DEBUG)" "CFLAGS = $(CFLAGS) $(CFLAGS_DEBUG)" all
... ...
nc_rar.F
... ... @@ -15,9 +15,33 @@
15 15 * See (Voir): http://www.cgd.ucar.edu/cms/eaton/cf-metadata/CF-current.html#gath
16 16 * for reference
17 17 *
18   -* $Id: nc_rar.F,v 1.4 2007-04-19 19:03:17 caveenj Exp $
  18 +
  19 +
  20 +* $Id: nc_rar.F,v 1.5 2009-06-09 17:25:15 caveenj Exp $
19 21 *
20 22 * $Log: not supported by cvs2svn $
  23 +* Revision 1.4.2.4 2009/06/09 17:20:11 caveenj
  24 +* Remplacement de -111 par ef_unspecified_int4 pour verifier si un axe est defini ou non
  25 +*
  26 +* Revision 1.4.2.3 2007/12/05 15:14:27 caveenj
  27 +* Correction de coquilles et ajout de documentation en anglais
  28 +*
  29 +* Revision 1.4.2.2 2007/11/28 18:50:47 caveenj
  30 +* Correction d'un bogue dans nc_rar pour le calcul des dimx et dimy
  31 +* On utilise maintenant la fonction ef_get_arg_extremes pour obtenir
  32 +* l'etendue complete du domaine.
  33 +* Ajout de code permettamt de traiter des variables 2D avec un indexwet2d
  34 +* et des variables 3D avec un indexwet3d.
  35 +*
  36 +* Ajout de la fonction rom_flip qui retourne un champ selon
  37 +* l'axe des Y (IROM) afin de faciliter l'affichage.
  38 +*
  39 +* Revision 1.4.2.1 2007/08/31 19:43:26 caveenj
  40 +* Nouvelle version de nc_rar qui utiise une variable au lieu d'un axe
  41 +* pour conserver les coordonnees composites des points de grille
  42 +* Cette nouvelle version elimine le besion de definir un axe de type
  43 +* spacing uneven pour les points mouilles
  44 +*
21 45 * Revision 1.3 2007/02/14 14:43:34 caveenj
22 46 * Correction d'un bogue de calcul d'indices par l'ajout d'un test permettant
23 47 * de s'assurer que les limites min-max des axes du tableau de sortie soient
... ... @@ -72,12 +96,12 @@
72 96 * |
73 97 * V
74 98  
75   - CALL ef_set_desc(id,'Reconstruire des axes reduits'//
  99 + CALL ef_set_desc(id,'Reconstruire des Axes Reduits'//
76 100 $ ' - Reduced Axes Reconstruction' )
77 101  
78   - CALL ef_set_num_args(id, 2)
79   - CALL ef_set_axis_inheritance(id, ABSTRACT,
80   - . ABSTRACT,IMPLIED_BY_ARGS, IMPLIED_BY_ARGS)
  102 + CALL ef_set_num_args(id, 3)
  103 + CALL ef_set_axis_inheritance(id, IMPLIED_BY_ARGS,
  104 + . IMPLIED_BY_ARGS,IMPLIED_BY_ARGS, IMPLIED_BY_ARGS)
81 105 CALL ef_set_piecemeal_ok(id, NO, NO, NO, NO)
82 106  
83 107 arg = 1
... ... @@ -93,7 +117,12 @@
93 117 CALL ef_set_axis_influence(id, arg, NO, NO, NO, YES)
94 118  
95 119  
96   - CALL ef_set_num_work_arrays(id, 1)
  120 + arg = 3
  121 + CALL ef_set_arg_name(id, arg, 'C')
  122 + call ef_set_arg_desc(id,arg,'Champ des indices pts mouilles - ' //
  123 + $ 'Wet point indices field')
  124 + CALL ef_set_axis_influence(id, arg, NO, NO, NO, NO)
  125 +
97 126  
98 127 * ^
99 128 * |
... ... @@ -104,135 +133,22 @@
104 133 END
105 134  
106 135  
107   -*
108   -*
109   -* Fonction pour calculer les limites des axes X et Y
110   -* du tableau de sortie
111   -*
112   -* Function to calculate the limits of the abstract X and Y axes of the
113   -* result matrix
114   -*
115   -*
116   -
117   - subroutine nc_rar_result_limits(id)
118   -
119   - implicit none
120   -
121   - INCLUDE 'ferret_cmn/EF_Util.cmn'
122   - INCLUDE 'ferret_cmn/EF_mem_subsc.cmn'
123   -
124   - INTEGER id
125   -
126   -* **********************************************************************
127   -* USER CONFIGURABLE PORTION |
128   -* |
129   -* V
130   - INTEGER my_lo_x, my_hi_x, my_lo_y, my_hi_y
131   - integer nx,ny
132   -
133   - INTEGER arg_lo_ss(4,EF_MAX_ARGS), arg_hi_ss(4,EF_MAX_ARGS),
134   - . arg_incr(4,EF_MAX_ARGS)
135   -
136   -*
137   -* Use utility functions to get context information about the arguments.
138   -* Set the abstract X Y.
139   -*
140   -* les proprietes de l'axe Z sont heritees du premier champ passe en argument
141   -* lors de l'appel a la fonction nc_rar
142   -*
143   -* Properties of the Z axis are inherited from the grid of the first
144   -* argument supplied to nc_rar()
145   -
146   - CALL ef_get_arg_subscripts(id, arg_lo_ss, arg_hi_ss, arg_incr)
147   -
148   - nx = arg_hi_ss(X_AXIS, ARG1) - arg_lo_ss(X_AXIS, ARG1) + 1
149   - ny = arg_hi_ss(Y_AXIS, ARG1) - arg_lo_ss(Y_AXIS, ARG1) + 1
150   -
151   -* Nos axes X et Y sont de type ABSTRACT, on les reindice donc a partir de 1
152   -*
153   -* Our X and Y axis ar of type ABSTRACT, so re-index starting from 1
154   -
155   - my_lo_x = 1
156   - my_hi_x = nx
157   - my_lo_y = 1
158   - my_hi_y = ny
159 136  
160 137  
161   - CALL ef_set_axis_limits(id, X_AXIS, my_lo_x, my_hi_x)
162   - CALL ef_set_axis_limits(id, Y_AXIS, my_lo_y, my_hi_y)
163   -
164   -
165   -* ^
166   -* |
167   -* USER CONFIGURABLE PORTION |
168   -* **********************************************************************
169   -
170   - RETURN
171   -
172   - END
173   -
174   -
175   -*
176   -*
177   -* Fonction pour initialiser un espace de travail
178   -* qui contiendra les coordonnees reelles de l'axe wet
179   -*
180   -* Note: les coordonnees sont de type real*8
181   -*
182   -* Function to initialise a work vector where the actual coordinates
183   -*(i.e., indices) of the compressed axis will be stored
184   -*
185   - subroutine nc_rar_work_size(id)
186   -
187   - implicit none
188   -
189   -
190   -
191   - INCLUDE 'ferret_cmn/EF_Util.cmn'
192   - INCLUDE 'ferret_cmn/EF_mem_subsc.cmn'
193   -
194   - INTEGER id
195   -
196   - integer nxout
197   -
198   - INTEGER arg_lo_ss(4,EF_MAX_ARGS), arg_hi_ss(4,EF_MAX_ARGS),
199   - $ arg_incr(4,EF_MAX_ARGS)
200   -
201   -
202   - call ef_get_arg_subscripts(id,arg_lo_ss,arg_hi_ss,arg_incr)
203   -
204   - nxout = 1 + arg_hi_ss(X_AXIS,ARG2) -arg_lo_ss(X_AXIS,ARG2)
205   -
206   -*
207   -*Definition du tableau de travail XAX
208   -*
209   -* Les coordonnees qui seront contenues dans xax sont en real*8
210   -* donc, on double l'espace requis
211   -*
212   -*Define the work XAX work array
213   -*
214   -*Coordinates that will be stored there by the ef_get_coordinates() function
215   -*are of type real*8, so we double up the required space
216   -*
217   - nxout = nxout * 2
218   - call ef_set_work_array_dims(id,1,1,1,1,1,nxout,1,1,1)
219   -
220   - return
221   - end
222   -
223 138 *
224 139 * Fonction calculant le resultat
225 140 *
226 141 * In this subroutine we compute the result
227 142 *
  143 +*
228 144 *Parameters:
229 145 * arg_1: dummy variable used to describe the target (2)3D grig
230   -* arg_2: field to uncompress
  146 +* arg_2: 2d or 3d field to uncompress
  147 +* arg_3: field containing the composite indices of the 2D 3D field
231 148 * result: the resulting (2)3D field
232   -* xax : work space to hold coordinates (indices)
233   -*
234 149  
235   - SUBROUTINE nc_rar_compute(id, arg_1, arg_2, result,xax)
  150 +
  151 + SUBROUTINE nc_rar_compute(id, arg_1, arg_2, arg_3, result)
236 152  
237 153 implicit none
238 154  
... ... @@ -249,25 +165,13 @@
249 165 REAL arg_2(mem2lox:mem2hix, mem2loy:mem2hiy,
250 166 . mem2loz:mem2hiz, mem2lot:mem2hit)
251 167  
  168 +
  169 + REAL arg_3(mem3lox:mem3hix, mem3loy:mem3hiy,
  170 + . mem3loz:mem3hiz, mem3lot:mem3hit)
  171 +
252 172 REAL result(memreslox:memreshix, memresloy:memreshiy,
253 173 . memresloz:memreshiz, memreslot:memreshit)
254 174  
255   -*
256   -* Le tableau XAX est un tableau de travail qui contiendra
257   -* les coordonnnes des points sur le vecteur comprime (pts mouilles)
258   -* On divise la dimension wrk1hix par 2 car dans la fonction
259   -* d'allocation d'espace de travail, on a alloue deux fois
260   -* plus d'espace pour tenir compte du fait que xax est real*8
261   -*
262   -* XAX is meant to hold the actual 3D cell coordinates
263   -* We divide the wrk1hix dimension by 2 because the work array
264   -* allocated in nc_rar_work_size() was twice the actual size required
265   -* because coordinates are real*8 while nc_rar_work_size() allocates
266   -* real*4
267   -*
268   - real*8 xax(wrk1lox:wrk1hix/2,wrk1loy:wrk1hiy,wrk1loz:wrk1hiz,
269   - $ wrk1lot:wrk1hit)
270   -
271 175 * After initialization, the 'res_' arrays contain indexing information
272 176 * for the result axes. The 'arg_' arrays will contain the indexing
273 177 * information for each variable's axes.
... ... @@ -276,6 +180,9 @@
276 180 INTEGER arg_lo_ss(4,EF_MAX_ARGS), arg_hi_ss(4,EF_MAX_ARGS),
277 181 $ arg_incr(4,EF_MAX_ARGS)
278 182  
  183 + INTEGER ss_min(4,EF_MAX_ARGS), ss_max(4,EF_MAX_ARGS)
  184 +
  185 +
279 186  
280 187 ************************************************************************
281 188 * USER CONFIGURABLE PORTION |
... ... @@ -284,26 +191,102 @@
284 191  
285 192 INTEGER i,j,k,l
286 193 INTEGER i2, j2, k2, l2
  194 + INTEGER i3, j3, k3, l3
287 195  
288 196 integer arg
289 197 character*100 errtxt
290 198  
291   - integer dimxy,dimx,indx,indy,indz,indice
292   -
  199 + integer dimxy,dimx,indx,indy,indz,indice,dimy
293 200  
  201 +
294 202 CALL ef_get_res_subscripts(id, res_lo_ss, res_hi_ss, res_incr)
295 203 CALL ef_get_arg_subscripts(id, arg_lo_ss, arg_hi_ss, arg_incr)
296 204 CALL ef_get_bad_flags(id, bad_flag, bad_flag_result)
297   -
298   - arg = 2
299 205  
  206 +C
  207 +C Ici on va chercher les extremes de TOUT le domaine
  208 +C afin de pouvoir calculer dimx et dimy qui servent a recalculer
  209 +C les indices i,j,k a partir de l'indice composite de indexwet
  210 +C
  211 +C Here we fetch the output domain extremes in order to
  212 +C calculate dimx and dimy wich are used in the calculation
  213 +C of the i,j,k indices from the "composite" wet index
  214 + call ef_get_arg_ss_extremes(id,1,ss_min,ss_max)
  215 +
  216 +
  217 +
  218 +
  219 +#if defined DEBUG
  220 + write(6,*)'extremes'
  221 +
  222 + write(6,*)'ss_min,ss_max X:',ss_min(X_AXIS,1),ss_max(X_AXIS,1)
  223 + write(6,*)'ss_min,ss_max Y:',ss_min(Y_AXIS,1),ss_max(Y_AXIS,1)
  224 + write(6,*)'ss_min ss_max Z',ss_min(Z_AXIS,1),ss_max(Z_AXIS,1)
  225 +
  226 +
  227 + write(6,*)'res_lo_ss(X_AXIS), res_hi_ss(X_AXIS)',
  228 + & res_lo_ss(X_AXIS), res_hi_ss(X_AXIS)
  229 +
  230 + write(6,*)'res_lo_ss(Y_AXIS), res_hi_ss(Y_AXIS)',
  231 + & res_lo_ss(Y_AXIS), res_hi_ss(Y_AXIS)
  232 +
  233 + write(6,*)'res_lo_ss(Z_AXIS), res_hi_ss(Z_AXIS)',
  234 + & res_lo_ss(Z_AXIS), res_hi_ss(Z_AXIS)
  235 +
  236 + write(6,*)'res_lo_ss(T_AXIS), res_hi_ss(T_AXIS)',
  237 + & res_lo_ss(T_AXIS), res_hi_ss(T_AXIS)
  238 +
  239 +
  240 +
300 241 *
301   -* Obtenir la liste des indices des points mouilles sur la grille 3D
302   -*
303   -* Fetch the actual indices on the 3D grid
304   - call ef_get_coordinates(id,arg,X_AXIS,arg_lo_ss(X_AXIS,
305   - $ ARG2),arg_hi_ss(X_AXIS,ARG2),xax)
  242 +*Calcul de l'indice de depart j et k du champ compresse
  243 +*cet indice demeure constant dans le calcul
  244 +* et est probablement = ef_unspecified_int4 ( i.e., non defini)
  245 + j2 = arg_lo_ss(Y_AXIS,ARG2)
  246 + k2 = arg_lo_ss(Z_AXIS,ARG2)
  247 + l2 = arg_lo_ss(T_AXIS,ARG2)
  248 +
  249 + j3 = arg_lo_ss(Y_AXIS,ARG3)
  250 + k3 = arg_lo_ss(Z_AXIS,ARG3)
  251 + l3 = arg_lo_ss(T_AXIS,ARG3)
  252 +
  253 +
  254 +
  255 + write(6,*)'mem1lox:mem1hix, mem1loy:mem1hiy,'//
  256 + & 'mem1loz:mem1hiz, mem1lot:mem1hit',
  257 + & mem1lox,mem1hix, mem1loy,mem1hiy,
  258 + & mem1loz,mem1hiz, mem1lot,mem1hit
  259 +
  260 +
  261 + i2=arg_lo_ss(X_AXIS,ARG2)
  262 + do i = 1,12
  263 + write(6,*)'arg_2:',arg_2(i2,j2,k2,l2)
  264 + i2 = i2 + arg_incr(X_AXIS,ARG2)
  265 + enddo
  266 +
  267 + i3=arg_lo_ss(X_AXIS,ARG3)
  268 + do i = 1,12
  269 + write(6,*)'arg_3:',arg_3(i3,j3,k3,l3)
  270 + i3 = i3 + arg_incr(X_AXIS,ARG3)
  271 + enddo
  272 +
  273 + write(6,*)'arg_lo_ss(X_AXIS,ARG1), arg_hi_ss(X_AXIS,ARG1),
  274 + & arg_incr(X_AXIS,ARG1)',arg_lo_ss(X_AXIS,ARG1),
  275 + & arg_hi_ss(X_AXIS,ARG1), arg_incr(X_AXIS,ARG1)
306 276  
  277 + write(6,*)'arg_lo_ss(Y_AXIS,ARG1), arg_hi_ss(Y_AXIS,ARG1),
  278 + & arg_incr(Y_AXIS,ARG1)',arg_lo_ss(Y_AXIS,ARG1),
  279 + & arg_hi_ss(Y_AXIS,ARG1), arg_incr(Y_AXIS,ARG1)
  280 +
  281 + write(6,*)'arg_lo_ss(Z_AXIS,ARG1), arg_hi_ss(Z_AXIS,ARG1),
  282 + & arg_incr(Z_AXIS,ARG1)',arg_lo_ss(Z_AXIS,ARG1),
  283 + & arg_hi_ss(Z_AXIS,ARG1), arg_incr(Z_AXIS,ARG1)
  284 +
  285 + write(6,*)'arg_lo_ss(T_AXIS,ARG1), arg_hi_ss(T_AXIS,ARG1),
  286 + & arg_incr(T_AXIS,ARG1)',arg_lo_ss(T_AXIS,ARG1),
  287 + & arg_hi_ss(T_AXIS,ARG1), arg_incr(T_AXIS,ARG1)
  288 +
  289 +#endif
307 290 C
308 291 C Initialiser le champ de sortie a des manquants
309 292 C Initialise output field to missing
... ... @@ -322,26 +305,45 @@ C
322 305  
323 306  
324 307  
  308 +C
  309 +C Reconstruction des axes de la grille 3D
  310 +C et des valeurs du champ sur cette grille
  311 +C
  312 +C Rebuild axes for (2)3D grid and scatter values
  313 +C of the field unto the grid
  314 +C
  315 +
  316 +
  317 +
325 318 *
326 319 * Calcul des dimensions necessaires au calcul des coordonnees
327 320 * Compute constants required to decompress
328 321 *
329 322  
330   - dimxy = res_hi_ss(X_AXIS)*res_hi_ss(Y_AXIS)
331   - dimx = res_hi_ss(X_AXIS)
332   -
  323 + dimx = ss_max(X_AXIS,1) - ss_min(X_AXIS,1) + 1
  324 + dimy = ss_max(Y_AXIS,1) - ss_min(Y_AXIS,1) + 1
  325 + dimxy = dimx * dimy
  326 +
  327 +
  328 +
333 329 *
334 330 *Calcul de l'indice de depart j et k du champ compresse
335 331 *cet indice demeure constant dans le calcul
336   -* et est probablement = -111 ( i.e., non defini)
  332 +* et est probablement = ef_unspecified_int4 ( i.e., non defini)
  333 +
337 334 *
338 335 * Compute the starting index for j and k (all data is stored
339 336 * along x and t in compressed format)
340 337 * Theses indices remain constant throughout calculation and are
341   -* most likely == to -111 (i.e., undefined)
  338 +* most likely == ef_unspecified_int4 (i.e., undefined)
342 339  
343 340 j2 = arg_lo_ss(Y_AXIS,ARG2)
344 341 k2 = arg_lo_ss(Z_AXIS,ARG2)
  342 + l2 = arg_lo_ss(T_AXIS,ARG2)
  343 +
  344 + j3 = arg_lo_ss(Y_AXIS,ARG3)
  345 + k3 = arg_lo_ss(Z_AXIS,ARG3)
  346 + l3 = arg_lo_ss(T_AXIS,ARG3)
345 347  
346 348  
347 349 * Ici, on boucle sur les coordonnes des points mouilles
... ... @@ -354,45 +356,89 @@ C
354 356 * Here, we loop on the compressed field coordinates in order to
355 357 * compute the i,j,k coordinates of the 3D field
356 358 * from the 1D coordinates
357   -* We then assing to result(i,j,k) the corredsonding value in the
  359 +* We then assing to result(i,j,k) the corresponding value in the
358 360 * compressed field
359   -*
360   - do i2 = arg_lo_ss(X_AXIS,ARG2),arg_hi_ss(X_AXIS,ARG2)
361   - indice = int(xax(i2,1,1,1))
362   - indz = (indice - 1)/dimxy
363   - indice = indice - indz*dimxy
364   - indy = (indice - 1)/dimx
365   - indx = indice - indy*dimx
366   - indz = indz + 1
367   - indy = indy + 1
368   -
369   -*
370   -* On s'assure que les indices calcules sont a
371   -* l'interieur du domaine demande
372   -*
373   -* Making sure that the computed indices fall within
374   -* the requested region
375   -*
376   - if( (indx .ge. res_lo_ss(X_AXIS) .and.
377   - & indx .le. res_hi_ss(X_AXIS)) .and.
378   - & (indy .ge. res_lo_ss(Y_AXIS) .and.
379   - & indy .le. res_hi_ss(Y_AXIS)) .and.
380   - & (indz .ge. res_lo_ss(Z_AXIS) .and.
381   - & indz .le. res_hi_ss(Z_AXIS))) then
382   -
383   -
384   -*
385   -* On repete l'operation pour chaque pas de temps demande
386   -* Repeat for all requested time step
387   -*
388   - l2 = arg_lo_ss(T_AXIS,ARG2)
389   -
390   - do l = res_lo_ss(T_AXIS),res_hi_ss(T_AXIS)
391   - result(indx,indy,indz,l) = arg_2(i2,j2,k2,l2)
392   - l2 = l2 + arg_incr(T_AXIS,ARG2)
393   - enddo
394   - endif
395   - enddo
  361 +*
  362 +* 3D
  363 + if(ss_min(Z_AXIS,1) .ne. ef_unspecified_int4 ) then
  364 + i2 = arg_lo_ss(X_AXIS,ARG2)
  365 + do i3 = arg_lo_ss(X_AXIS,ARG2),arg_hi_ss(X_AXIS,ARG2)
  366 + indice = int( arg_3( i3, j3, k3, l3) )
  367 + indz = (indice - 1)/dimxy
  368 + indice = indice - indz*dimxy
  369 + indy = (indice - 1)/dimx
  370 + indx = indice - indy*dimx
  371 + indz = indz + 1
  372 + indy = indy + 1
  373 +*
  374 +* On s'assure que les indices calcules sont a
  375 +* l'interieur du domaine demande
  376 +*
  377 +*
  378 +* Making sure that the computed indices fall within
  379 +* the requested region
  380 +*
  381 + if( (indx .ge. res_lo_ss(X_AXIS) .and.
  382 + & indx .le. res_hi_ss(X_AXIS)) .and.
  383 + & (indy .ge. res_lo_ss(Y_AXIS) .and.
  384 + & indy .le. res_hi_ss(Y_AXIS)) .and.
  385 + & (indz .ge. res_lo_ss(Z_AXIS) .and.
  386 + & indz .le. res_hi_ss(Z_AXIS))) then
  387 +
  388 +
  389 +*
  390 +* On repete l'operation pour chaque pas de temps demande
  391 +* Repeat for all requested time step
  392 +*
  393 + l2 = arg_lo_ss(T_AXIS,ARG2)
  394 +
  395 + do l = res_lo_ss(T_AXIS),res_hi_ss(T_AXIS)
  396 + result(indx,indy,indz,l) = arg_2(i2,j2,k2,l2)
  397 + l2 = l2 + arg_incr(T_AXIS,ARG2)
  398 + enddo
  399 + endif
  400 + i2 = i2 + arg_incr(X_AXIS,ARG2)
  401 + enddo
  402 +
  403 +C 2D
  404 + else
  405 +
  406 + indz = ef_unspecified_int4
  407 + i2 = arg_lo_ss(X_AXIS,ARG2)
  408 + do i3 = arg_lo_ss(X_AXIS,ARG2),arg_hi_ss(X_AXIS,ARG2)
  409 + indice = int( arg_3( i3, j3, k3, l3) )
  410 + indy = (indice - 1)/dimx
  411 + indx = indice - indy*dimx
  412 + indy = indy + 1
  413 +*
  414 +* On s'assure que les indices calcules sont a
  415 +* l'interieur du domaine demande
  416 +*
  417 +*
  418 +* Making sure that the computed indices fall within
  419 +* the requested region
  420 +*
  421 + if( (indx .ge. res_lo_ss(X_AXIS) .and.
  422 + & indx .le. res_hi_ss(X_AXIS)) .and.
  423 + & (indy .ge. res_lo_ss(Y_AXIS) .and.
  424 + & indy .le. res_hi_ss(Y_AXIS)) ) then
  425 +
  426 +
  427 +*
  428 +* On repete l'operation pour chaque pas de temps demande
  429 +* Repeat for all requested time step
  430 +*
  431 + l2 = arg_lo_ss(T_AXIS,ARG2)
  432 +
  433 + do l = res_lo_ss(T_AXIS),res_hi_ss(T_AXIS)
  434 + result(indx,indy,indz,l) = arg_2(i2,j2,k2,l2)
  435 + l2 = l2 + arg_incr(T_AXIS,ARG2)
  436 + enddo
  437 + endif
  438 + i2 = i2 + arg_incr(X_AXIS,ARG2)
  439 + enddo
  440 +
  441 + endif
396 442  
397 443  
398 444  
... ...
rom_flip.F 0 → 100644
... ... @@ -0,0 +1,194 @@
  1 +*
  2 +* rom_flip.F
  3 +*
  4 +* James Caveen - UQAR
  5 +* Janvier 2007
  6 +*
  7 +* rom_flip.F: Retourner l'axe Y (IROM) du modele ROM
  8 +* Flip the Y (IROM) axis of the ROM model
  9 +
  10 +
  11 +* $Id: rom_flip.F,v 1.2 2009-06-09 17:25:15 caveenj Exp $
  12 +*
  13 +* $Log: not supported by cvs2svn $
  14 +* Revision 1.1.2.1 2007/11/28 18:50:47 caveenj
  15 +* Correction d'un bogue dans nc_rar pour le calcul des dimx et dimy
  16 +* On utilise maintenant la fonction ef_get_arg_extremes pour obtenir
  17 +* l'etendue complete du domaine.
  18 +* Ajout de code permettamt de traiter des variables 2D avec un indexwet2d
  19 +* et des variables 3D avec un indexwet3d.
  20 +*
  21 +* Ajout de la fonction rom_flip qui retourne un champ selon
  22 +* l'axe des Y (IROM) afin de faciliter l'affichage.
  23 +*
  24 +*
  25 +*
  26 +*
  27 +*
  28 +* In this subroutine we provide information about
  29 +* the function. The user configurable information
  30 +* consists of the following:
  31 +*
  32 +* descr Text description of the function
  33 +*
  34 +* num_args Required number of arguments
  35 +*
  36 +* axis_inheritance Type of axis for the result
  37 +* ( CUSTOM, IMPLIED_BY_ARGS, NORMAL, ABSTRACT )
  38 +* CUSTOM - user defined axis
  39 +* IMPLIED_BY_ARGS - same axis as the incoming argument
  40 +* NORMAL - the result is normal to this axis
  41 +* ABSTRACT - an axis which only has index values
  42 +*
  43 +* piecemeal_ok For memory optimization:
  44 +* axes where calculation may be performed piecemeal
  45 +* ( YES, NO )
  46 +*
  47 +*
  48 +* For each argument we provide the following information:
  49 +*
  50 +* name Text name for an argument
  51 +*
  52 +* unit Text units for an argument
  53 +*
  54 +* desc Text description of an argument
  55 +*
  56 +* axis_influence Are this argument's axes the same as the result grid?
  57 +* ( YES, NO )
  58 +*
  59 +* axis_extend How much does Ferret need to extend arg limits relative to result
  60 +*
  61 +
  62 +
  63 + SUBROUTINE rom_flip_init(id)
  64 +
  65 + INCLUDE 'ferret_cmn/EF_Util.cmn'
  66 +
  67 + INTEGER id, arg
  68 +
  69 +************************************************************************
  70 +* USER CONFIGURABLE PORTION |
  71 +* |
  72 +* V
  73 +
  74 + CALL ef_set_desc(id,'Retourner l''axe Y (IROM)'//
  75 + $ ' - Flip Y (IROM) axis' )
  76 +
  77 + CALL ef_set_num_args(id, 1)
  78 + CALL ef_set_axis_inheritance(id, IMPLIED_BY_ARGS,
  79 + . IMPLIED_BY_ARGS,IMPLIED_BY_ARGS, IMPLIED_BY_ARGS)
  80 + CALL ef_set_piecemeal_ok(id, NO, NO, NO, NO)
  81 +
  82 + arg = 1
  83 + CALL ef_set_arg_name(id, arg, 'A')
  84 + CALL ef_set_arg_desc(id, arg,'Champ a retourner '//
  85 + $ ' - Field to flip')
  86 + CALL ef_set_axis_influence(id, arg, YES, YES, YES, YES)
  87 +
  88 +
  89 +* ^
  90 +* |
  91 +* USER CONFIGURABLE PORTION |
  92 +************************************************************************
  93 +
  94 + RETURN
  95 + END
  96 +
  97 +
  98 +
  99 +
  100 +*
  101 +* Fonction calculant le resultat
  102 +*
  103 +* In this subroutine we compute the result
  104 +*
  105 +*
  106 +*Parameters:
  107 +* arg_1: dummy variable used to describe the target (2)3D grig
  108 +* arg_2: 2d or 3d field to uncompress
  109 +* arg_3: field containig the composite indices of the 2D 3D field
  110 +* result: the resulting (2)3D field
  111 +
  112 +
  113 + SUBROUTINE rom_flip_compute(id, arg_1, result)
  114 +
  115 + implicit none
  116 +
  117 + INCLUDE 'ferret_cmn/EF_Util.cmn'
  118 + INCLUDE 'ferret_cmn/EF_mem_subsc.cmn'
  119 +
  120 + INTEGER id
  121 +
  122 + REAL bad_flag(EF_MAX_ARGS), bad_flag_result
  123 +
  124 + REAL arg_1(mem1lox:mem1hix, mem1loy:mem1hiy,
  125 + . mem1loz:mem1hiz, mem1lot:mem1hit)
  126 +
  127 + REAL arg_2(mem2lox:mem2hix, mem2loy:mem2hiy,
  128 + . mem2loz:mem2hiz, mem2lot:mem2hit)
  129 +
  130 +
  131 + REAL arg_3(mem3lox:mem3hix, mem3loy:mem3hiy,
  132 + . mem3loz:mem3hiz, mem3lot:mem3hit)
  133 +
  134 + REAL result(memreslox:memreshix, memresloy:memreshiy,
  135 + . memresloz:memreshiz, memreslot:memreshit)
  136 +
  137 +* After initialization, the 'res_' arrays contain indexing information
  138 +* for the result axes. The 'arg_' arrays will contain the indexing
  139 +* information for each variable's axes.
  140 +
  141 + INTEGER res_lo_ss(4), res_hi_ss(4), res_incr(4)
  142 + INTEGER arg_lo_ss(4,EF_MAX_ARGS), arg_hi_ss(4,EF_MAX_ARGS),
  143 + $ arg_incr(4,EF_MAX_ARGS)
  144 +
  145 +
  146 +************************************************************************
  147 +* USER CONFIGURABLE PORTION |
  148 +* |
  149 +* V
  150 +
  151 + INTEGER i,j,k,l
  152 + INTEGER i1, j1, k1, l1
  153 +
  154 + integer arg
  155 + character*100 errtxt
  156 +
  157 +
  158 + CALL ef_get_res_subscripts(id, res_lo_ss, res_hi_ss, res_incr)
  159 + CALL ef_get_arg_subscripts(id, arg_lo_ss, arg_hi_ss, arg_incr)
  160 + CALL ef_get_bad_flags(id, bad_flag, bad_flag_result)
  161 +
  162 +C
  163 +C Initialiser le champ de sortie a des manquants
  164 +C Initialise output field to missing
  165 +C
  166 + i1 = arg_lo_ss(X_AXIS,ARG1)
  167 + do i=res_lo_ss(X_AXIS), res_hi_ss(X_AXIS)
  168 + j1 = arg_lo_ss(Y_AXIS,ARG1)
  169 + do j=res_hi_ss(Y_AXIS), res_lo_ss(Y_AXIS),-1
  170 + k1 = arg_lo_ss(Z_AXIS,ARG1)
  171 + do k=res_lo_ss(Z_AXIS), res_hi_ss(Z_AXIS)
  172 + l1 = arg_lo_ss(T_AXIS,ARG1)
  173 + do l=res_lo_ss(T_AXIS), res_hi_ss(T_AXIS)
  174 + result(i,j,k,l) = arg_1(i1,j1,k1,l1)
  175 + l1 = l1 + arg_incr(T_AXIS,ARG1)
  176 + enddo
  177 + k1 = k1 + arg_incr(Z_AXIS,ARG1)
  178 + enddo
  179 + j1 = j1 + arg_incr(Y_AXIS,ARG1)
  180 + enddo
  181 + i1 = i1 + arg_incr(X_AXIS,ARG1)
  182 + enddo
  183 +
  184 +
  185 +
  186 +
  187 +
  188 +* ^
  189 +* |
  190 +* USER CONFIGURABLE PORTION |
  191 +************************************************************************
  192 +
  193 + RETURN
  194 + END
... ...
test_ferret.go 0 → 100644
... ... @@ -0,0 +1,36 @@
  1 + ! NOAA/PMEL TMAP
  2 + ! FERRET v6
  3 + ! Linux(g77) 2.4.21-32 - 08/23/06
  4 + ! 25-Jan-07 09:35
  5 +
  6 +set memory/size=500
  7 +use temp_avec_iwet3d.nc
  8 +let a = x[gx=xgulf]*0 + y[gy=ygulf]*0 + z[gz=zgulf]*0 + t[gt=tgulf]*0
  9 +let b = nc_rar(a,temp,indexwet3d)
  10 +shade b[l=1,k=1]
  11 +
  12 +set window 2
  13 +shade b[l=3,k=10,i=20:200:2]
  14 +
  15 +
  16 +set window 3
  17 +shade b[l=2,j=40]
  18 +let c = nc_rar(a,temp,indexwet3d)
  19 +
  20 +let d = c[l=4] - b[l=3]
  21 +set window 4
  22 +shade d[k=2]
  23 +
  24 +set window 5
  25 +shade d[z=@din]
  26 +
  27 +use ll5km.nc
  28 +
  29 +set window 6
  30 +shade d[k=2,d=1],lon[d=2],lat[d=2]
  31 +set window 7
  32 +shade b[l=2,i=80,d=1]
  33 +
  34 +set window 8
  35 +shade b[z=@din,t=@sum,d=1]
  36 +quit
... ...