Commit fcccab975f48cac3f7ce3097e7bf9924763102ce

Authored by caveenj
1 parent 51682502
Exists in master

Fonction nc_rar pour ferret

Showing 2 changed files with 403 additions and 0 deletions   Show diff stats
Makefile 0 → 100644
... ... @@ -0,0 +1,65 @@
  1 +#
  2 +# Makefile pour compiler les fonctions externes
  3 +# developpees à l'ISMER
  4 +#
  5 +# Construit pa James Caveen a partir du Makefile
  6 +# deja fourni par ferret fevrier 2007
  7 +#
  8 +# January 20 1998
  9 +# Jonathan Callahan
  10 +#
  11 +# 15-Nov-1999 Ansley Manke
  12 +# remove refs to ef_utility/*.o (now in ferret executable)
  13 +#
  14 +# include platform specific macro definitions
  15 +#
  16 +HOSTTYPE = i486-linux
  17 +
  18 +#MY_EXTFCNS = /home/caveenj/projets/ferret_compnc/external_fcns
  19 +
  20 +#
  21 +# Pour le developpement, adapter la valeur de FER_LOCAL_EXTFCNS
  22 +#selon vos besoins
  23 +#
  24 +
  25 +#FER_LOCAL_EXTFCNS = $(MY_EXTFCNS)
  26 +
  27 +include ../ef_utility/platform_specific_flags.mk.$(HOSTTYPE)
  28 +
  29 +
  30 +#
  31 +# Macros
  32 +#
  33 +
  34 +.SUFFIXES: .so
  35 +
  36 +#
  37 +# Rules
  38 +#
  39 +
  40 +.F.so:
  41 + $(F77) $(FFLAGS) -c $<
  42 + $(LD) $(LD_DYN_FLAGS) $(SYSLIBS) $*.o -o $*.so
  43 +
  44 +
  45 +#
  46 +# Targets
  47 +#
  48 +
  49 +all: ferret_cmn nc_rar.so
  50 +
  51 +debug:
  52 + $(MAKE) "FFLAGS = $(FFLAGS) $(FFLAGS_DEBUG)" "CFLAGS = $(CFLAGS) $(CFLAGS_DEBUG)" all
  53 +
  54 +ferret_cmn:
  55 + ln -s ../ef_utility/ferret_cmn ferret_cmn
  56 +
  57 +install:
  58 + cp *.so $(FER_LOCAL_EXTFCNS)
  59 +
  60 +clean:
  61 + -rm -f *.o *.so core a.out temp.* ferret_cmn
  62 +
  63 +#
  64 +# End of Makefile
  65 +#
... ...
nc_rar.F 0 → 100644
... ... @@ -0,0 +1,338 @@
  1 +*
  2 +* nc_rar.F
  3 +*
  4 +* James Caveen - UQAR
  5 +* Janvier 2007
  6 +*
  7 +* nc_rar.F: reconstruire les axes reduits
  8 +* reduced axes reconstruction
  9 +* Decompresse un champ de points mouilles et
  10 +* reconstruit le champ 3D correspondant
  11 +*
  12 +*
  13 +*
  14 +* In this subroutine we provide information about
  15 +* the function. The user configurable information
  16 +* consists of the following:
  17 +*
  18 +* descr Text description of the function
  19 +*
  20 +* num_args Required number of arguments
  21 +*
  22 +* axis_inheritance Type of axis for the result
  23 +* ( CUSTOM, IMPLIED_BY_ARGS, NORMAL, ABSTRACT )
  24 +* CUSTOM - user defined axis
  25 +* IMPLIED_BY_ARGS - same axis as the incoming argument
  26 +* NORMAL - the result is normal to this axis
  27 +* ABSTRACT - an axis which only has index values
  28 +*
  29 +* piecemeal_ok For memory optimization:
  30 +* axes where calculation may be performed piecemeal
  31 +* ( YES, NO )
  32 +*
  33 +*
  34 +* For each argument we provide the following information:
  35 +*
  36 +* name Text name for an argument
  37 +*
  38 +* unit Text units for an argument
  39 +*
  40 +* desc Text description of an argument
  41 +*
  42 +* axis_influence Are this argument's axes the same as the result grid?
  43 +* ( YES, NO )
  44 +*
  45 +* axis_extend How much does Ferret need to extend arg limits relative to result
  46 +*
  47 +
  48 +
  49 + SUBROUTINE nc_rar_init(id)
  50 +
  51 + INCLUDE 'ferret_cmn/EF_Util.cmn'
  52 +
  53 + INTEGER id, arg
  54 +
  55 +************************************************************************
  56 +* USER CONFIGURABLE PORTION |
  57 +* |
  58 +* V
  59 +
  60 + CALL ef_set_desc(id,'Reconstruire des axes reduits'//
  61 + $ ' - reduced axes reconstruction' )
  62 +
  63 + CALL ef_set_num_args(id, 2)
  64 + CALL ef_set_axis_inheritance(id, ABSTRACT,
  65 + . ABSTRACT,IMPLIED_BY_ARGS, IMPLIED_BY_ARGS)
  66 + CALL ef_set_piecemeal_ok(id, NO, NO, NO, NO)
  67 +
  68 + arg = 1
  69 + CALL ef_set_arg_name(id, arg, 'A')
  70 + CALL ef_set_arg_desc(id, arg,'Champ decrivant la grille de sortie'//
  71 + $ '- Field describing output grid')
  72 + CALL ef_set_axis_influence(id, arg, YES, YES, YES, YES)
  73 +
  74 + arg = 2
  75 + CALL ef_set_arg_name(id, arg, 'B')
  76 + call ef_set_arg_desc(id,arg,'Champ a reconstruire - ' //
  77 + $ 'Field to rebuild')
  78 + CALL ef_set_axis_influence(id, arg, NO, NO, NO, YES)
  79 +
  80 +
  81 + CALL ef_set_num_work_arrays(id, 1)
  82 +
  83 +* ^
  84 +* |
  85 +* USER CONFIGURABLE PORTION |
  86 +************************************************************************
  87 +
  88 + RETURN
  89 + END
  90 +
  91 + subroutine nc_rar_result_limits(id)
  92 +
  93 +
  94 +
  95 + INCLUDE 'ferret_cmn/EF_Util.cmn'
  96 + INCLUDE 'ferret_cmn/EF_mem_subsc.cmn'
  97 +
  98 + INTEGER id
  99 +
  100 +* **********************************************************************
  101 +* USER CONFIGURABLE PORTION |
  102 +* |
  103 +* V
  104 + INTEGER my_lo_x, my_hi_x, my_lo_y, my_hi_y
  105 + CHARACTER*100 errtxt
  106 +
  107 + INTEGER arg_lo_ss(4,EF_MAX_ARGS), arg_hi_ss(4,EF_MAX_ARGS),
  108 + . arg_incr(4,EF_MAX_ARGS)
  109 +
  110 +*
  111 +* Use utility functions to get context information about the arguments.
  112 +* Set the abstract X Y.
  113 +*
  114 +* les proprietes de l'axe Z sont heritees du premier champ passe en argument
  115 +* lors de l'appel a la fonction nc_rar
  116 +*
  117 +
  118 + CALL ef_get_arg_subscripts(id, arg_lo_ss, arg_hi_ss, arg_incr)
  119 +
  120 + nx = arg_hi_ss(X_AXIS, ARG1) - arg_lo_ss(X_AXIS, ARG1) + 1
  121 + ny = arg_hi_ss(Y_AXIS, ARG1) - arg_lo_ss(Y_AXIS, ARG1) + 1
  122 +
  123 +* Nos axes X et Y sont de type ABSTRACT, on les reindice donc a partir de 1
  124 +*
  125 +
  126 + my_lo_x = 1
  127 + my_hi_x = nx
  128 + my_lo_y = 1
  129 + my_hi_y = ny
  130 +
  131 +
  132 + CALL ef_set_axis_limits(id, X_AXIS, my_lo_x, my_hi_x)
  133 + CALL ef_set_axis_limits(id, Y_AXIS, my_lo_y, my_hi_y)
  134 +
  135 +
  136 +* ^
  137 +* |
  138 +* USER CONFIGURABLE PORTION |
  139 +* **********************************************************************
  140 +
  141 + RETURN
  142 +
  143 +
  144 + 999 CONTINUE
  145 +
  146 + CALL EF_BAIL_OUT(id, errtxt)
  147 +
  148 + END
  149 +
  150 +
  151 +*
  152 +*
  153 +* Dans cette fonction on initialise un espace de travail
  154 +* qui contiendra les coordonnees reelles de l'axe wet
  155 +*
  156 +* Note: les coordonnees sont de type real*8
  157 +*
  158 + subroutine nc_rar_work_size(id)
  159 +
  160 + implicit none
  161 +
  162 +
  163 +
  164 + INCLUDE 'ferret_cmn/EF_Util.cmn'
  165 + INCLUDE 'ferret_cmn/EF_mem_subsc.cmn'
  166 +
  167 + INTEGER id
  168 +
  169 + integer nxout
  170 +
  171 + character*100 errtxt
  172 +
  173 +
  174 + INTEGER arg_lo_ss(4,EF_MAX_ARGS), arg_hi_ss(4,EF_MAX_ARGS),
  175 + $ arg_incr(4,EF_MAX_ARGS)
  176 +
  177 +
  178 + call ef_get_arg_subscripts(id,arg_lo_ss,arg_hi_ss,arg_incr)
  179 +
  180 + nxout = 1 + arg_hi_ss(X_AXIS,ARG2) -arg_lo_ss(X_AXIS,ARG2)
  181 +
  182 +*
  183 +*Definition du tableau de travail XAX
  184 +*
  185 +*
  186 +* Les coordonnees qui seront contenues dans xax sont en real*8
  187 +* donc, on double l'espace requis
  188 +*
  189 + nxout = nxout * 2
  190 + call ef_set_work_array_dims(id,1,1,1,1,1,nxout,1,1,1)
  191 +
  192 + return
  193 + end
  194 +
  195 +*
  196 +* In this subroutine we compute the result
  197 +*
  198 + SUBROUTINE nc_rar_compute(id, arg_1, arg_2, result,xax)
  199 +
  200 + implicit none
  201 +
  202 + INCLUDE 'ferret_cmn/EF_Util.cmn'
  203 + INCLUDE 'ferret_cmn/EF_mem_subsc.cmn'
  204 +
  205 + INTEGER id
  206 +
  207 + REAL bad_flag(EF_MAX_ARGS), bad_flag_result
  208 +
  209 + REAL arg_1(mem1lox:mem1hix, mem1loy:mem1hiy,
  210 + . mem1loz:mem1hiz, mem1lot:mem1hit)
  211 +
  212 + REAL arg_2(mem2lox:mem2hix, mem2loy:mem2hiy,
  213 + . mem2loz:mem2hiz, mem2lot:mem2hit)
  214 +
  215 + REAL result(memreslox:memreshix, memresloy:memreshiy,
  216 + . memresloz:memreshiz, memreslot:memreshit)
  217 +
  218 +*
  219 +* Le tableau XAX est un tableau de travail qui contiendra
  220 +* les coordonnnes des points sur le vecteur comprime (pts mouilles)
  221 +*
  222 + real*8 xax(wrk1lox:wrk1hix,wrk1loy:wrk1hiy,wrk1loz:wrk1hiz,
  223 + $ wrk1lot:wrk1hit)
  224 +
  225 +* After initialization, the 'res_' arrays contain indexing information
  226 +* for the result axes. The 'arg_' arrays will contain the indexing
  227 +* information for each variable's axes.
  228 +
  229 + INTEGER res_lo_ss(4), res_hi_ss(4), res_incr(4)
  230 + INTEGER arg_lo_ss(4,EF_MAX_ARGS), arg_hi_ss(4,EF_MAX_ARGS),
  231 + $ arg_incr(4,EF_MAX_ARGS)
  232 +
  233 +
  234 +************************************************************************
  235 +* USER CONFIGURABLE PORTION |
  236 +* |
  237 +* V
  238 +
  239 + INTEGER i,j,k,l
  240 + INTEGER i2, j2, k2, l2
  241 +
  242 + integer arg
  243 + character*100 errtxt
  244 +
  245 + integer dimxy,dimx,indx,indy,indz,indice
  246 +
  247 + CALL ef_get_res_subscripts(id, res_lo_ss, res_hi_ss, res_incr)
  248 + CALL ef_get_arg_subscripts(id, arg_lo_ss, arg_hi_ss, arg_incr)
  249 + CALL ef_get_bad_flags(id, bad_flag, bad_flag_result)
  250 +
  251 + arg = 2
  252 +
  253 +*
  254 +* Obtenir la liste des indices des points mouilles sur la grille 3D
  255 +*
  256 + call ef_get_coordinates(id,arg,X_AXIS,arg_lo_ss(X_AXIS,
  257 + $ ARG2),arg_hi_ss(X_AXIS,ARG2),xax)
  258 +
  259 +
  260 +
  261 +
  262 +C
  263 +C Initialiser le champ de sortie a des manquants
  264 +C
  265 +
  266 + do i=res_lo_ss(X_AXIS), res_hi_ss(X_AXIS)
  267 + do j=res_lo_ss(Y_AXIS), res_hi_ss(Y_AXIS)
  268 + do k=res_lo_ss(Z_AXIS), res_hi_ss(Z_AXIS)
  269 + do l=res_lo_ss(T_AXIS), res_hi_ss(T_AXIS)
  270 + result(i,j,k,l) = bad_flag_result
  271 + enddo
  272 + enddo
  273 + enddo
  274 + enddo
  275 +
  276 +
  277 +
  278 +
  279 +C
  280 +C Reconstruction des axes de la grille 3D
  281 +C et des valeurs du champ sur cette grille
  282 +C
  283 +C
  284 +
  285 +
  286 +
  287 +*
  288 +* Calcul des dimensions necessaires au calcul des coordonnees
  289 +*
  290 +
  291 + dimxy = res_hi_ss(X_AXIS)*res_hi_ss(Y_AXIS)
  292 + dimx = res_hi_ss(X_AXIS)
  293 +
  294 +
  295 +*
  296 +*Calcul de l'indice de depart j et k du champ compresse
  297 +*cet indice demeure constant dans le calcul
  298 +*
  299 + j2 = arg_lo_ss(Y_AXIS,ARG2)
  300 + k2 = arg_lo_ss(Z_AXIS,ARG2)
  301 +
  302 +
  303 +*
  304 +* Ici, on boucle sur les coordonnes des points mouilles
  305 +* et on recalcule les coordonnes i,j,k du champ 3D
  306 +* a partir de la coordonnee 1D
  307 +* puis on assigne a result(i,j,k) la valeur
  308 +* correspondante dans le champ qui avait ete cree lors
  309 +* de la compression des axes (arg_2)
  310 +*
  311 +
  312 + do i2 = arg_lo_ss(X_AXIS,ARG2),arg_hi_ss(X_AXIS,ARG2)
  313 + indice = int(xax(i2,1,1,1))
  314 + indz = (indice - 1)/dimxy
  315 + indice = indice - indz*dimxy
  316 + indy = (indice - 1)/dimx
  317 + indx = indice - indy*dimx
  318 + indz = indz + 1
  319 + indy = indy + 1
  320 + l2 = arg_lo_ss(T_AXIS,ARG2)
  321 +*
  322 +* On repete l'operation pour chaque pas de temps demande
  323 +*
  324 + do l = res_lo_ss(T_AXIS),res_hi_ss(T_AXIS)
  325 + result(indx,indy,indz,l) = arg_2(i2,j2,k2,l2)
  326 + l2 = l2 + arg_incr(T_AXIS,ARG2)
  327 + enddo
  328 + enddo
  329 +
  330 +
  331 +
  332 +* ^
  333 +* |
  334 +* USER CONFIGURABLE PORTION |
  335 +************************************************************************
  336 +
  337 + RETURN
  338 + END
... ...