Télécharger la plaquette Cast3M


fr en

Télécharger ipgril.eso

Retour à la liste

Numérotation des lignes : 

ipgril

  1. C IPGRIL    SOURCE    PV090527  25/01/07    14:42:44     12115          
  2. C-----------------------------------------------------------------------
  3. C NOM         : IPGRIL
  4. C DESCRIPTION : Interpolation dans un NUAGE represantant une grille
  5. C               de valeurs
  6. C LANGAGE     : ESOPE
  7. C AUTEUR      : Francois DI PAOLA
  8. C-----------------------------------------------------------------------
  9. C APPELE PAR       : IPLNU1
  10. C APPELE           : IPMULI
  11. C-----------------------------------------------------------------------
  12. C ENTREES            : INUA (Objet de type NUAGE)
  13. C SORTIES            :
  14. C Lit un CHPOINT ou un MCHAML dans la pile puis ecrit un objet du meme
  15. C type en retour
  16. C-----------------------------------------------------------------------
  17. C VERSION    : v1, 02/10/2015, version initiale
  18. C HISTORIQUE : v1, 02/10/2015, creation
  19. C HISTORIQUE :
  20. C HISTORIQUE :
  21. C-----------------------------------------------------------------------
  22. C Priere de PRENDRE LE TEMPS de completer les commentaires
  23. C en cas de modification de ce sous-programme afin de faciliter
  24. C la maintenance !
  25. C-----------------------------------------------------------------------
  26. C REMARQUES : - L'interpolation est exacte, c'est-a-dire que l'on
  27. C               retrouve les valeurs de la grille si l'on interpole en
  28. C               un noeud de la grille
  29. C             - La grille peut contenir autant de dimensions que
  30. C               souhaitees
  31. C             - Pour le moment, seule l'interpolation multi-lineaire est
  32. C               disponible
  33. C             - Une interpolation par splines cubiques est possible sur
  34. C               la meme base (a faire plus tard ...)
  35. C-----------------------------------------------------------------------
  36. C
  37.       SUBROUTINE IPGRIL(INUA)
  38. C
  39.       IMPLICIT INTEGER(I-N)
  40.       IMPLICIT REAL*8 (A-H,O-Z)
  41. -INC CCNOYAU
  42.  
  43. -INC PPARAM
  44. -INC CCOPTIO
  45. -INC SMCOORD
  46. -INC SMNUAGE
  47. -INC SMCHPOI
  48. -INC SMCHAML
  49. -INC SMLREEL
  50. -INC SMLENTI
  51. -INC SMLMOTS
  52. -INC CCASSIS
  53.       CHARACTER*(LOCOMP)  MOT1,MOT2
  54.       LOGICAL      BTHRD
  55.  
  56.       SEGMENT SPARAL
  57.         INTEGER NNN,ML1,ML2,MPV1,MPV2,MCH1,MEL2,
  58.      &          N1EL1,N1PEL1
  59.         INTEGER IXX(NBTHR)
  60.       ENDSEGMENT
  61.  
  62.       SEGMENT SXX
  63.         REAL*8 XX(NDIM)
  64.       ENDSEGMENT
  65.  
  66. C
  67. C     Introduction d'un COMMON pour la parallelisation
  68.       COMMON/IPLMUC/IPARAL
  69.  
  70.       EXTERNAL IPMULi
  71.  
  72. C
  73. C     Pour la paralelisation de l'interpolation
  74. C
  75.       BTHRD = .FALSE.
  76.       IPARAL= 0
  77. C
  78. C
  79. C     Depouillement du nuage pour connaitre le nombre de dimensions de
  80. C     la grille
  81.       MNUAG1=INUA
  82.       SEGACT,MNUAG1
  83.       NNU=MNUAG1.NUAPOI(/1)
  84.       NDIM=NNU-1
  85.       IF (NDIM.LT.1) THEN
  86.         INTERR(1)=MNUAG1
  87.         INTERR(2)=2
  88.         INTERR(3)=1
  89.         CALL ERREUR(628)
  90.         RETURN
  91.       ENDIF
  92. C
  93. C     Initialisation d'une liste de mots pour stocker les noms des
  94. C     dimensions de la grille
  95.       JGN=LOCOMP
  96.       JGM=NNU
  97.       SEGINI,MLMOT1
  98. C
  99. C     Iniilisation d'une liste d'entiers pour stocker les pointeurs vers
  100. C     les LISTREEL definissant la grille de valeur de la fonction F
  101.       JG=NNU
  102.       SEGINI,MLENT1
  103. C
  104. C     Parcours du NUAGE pour verifications
  105.       NVAL=1
  106.       DO I=1,NNU
  107. C       Nom de la composante I
  108.         MOT1=MNUAG1.NUANOM(I)
  109. C       Et rangement du mot dans la liste de mots adhoc
  110.         MLMOT1.MOTS(I)=MOT1
  111. C       Les composantes doivent abriter 1 seul objet de type LISTREEL
  112.         MOT2=MNUAG1.NUATYP(I)
  113.         IF (MOT2.NE.'LISTREEL') THEN
  114.           CALL ERREUR(941)
  115.           RETURN
  116.         ENDIF
  117.         NUAVI1=MNUAG1.NUAPOI(I)
  118.         SEGACT,NUAVI1
  119.         NPO=NUAVI1.NUAINT(/1)
  120.         IF (NPO.NE.1) THEN
  121.           CALL ERREUR(941)
  122.           RETURN
  123.         ENDIF
  124.         MLREE1=NUAVI1.NUAINT(1)
  125. C       Verification de la taille de la derniere liste
  126.         SEGACT,MLREE1
  127.         IF (I.EQ.NNU) THEN
  128.           NTEST=MLREE1.PROG(/1)
  129.           IF (NTEST.NE.NVAL) THEN
  130.             CALL ERREUR(21)
  131.             RETURN
  132.           ENDIF
  133.         ELSE
  134.           NVAL=NVAL*(MLREE1.PROG(/1))
  135.         ENDIF
  136. C       Et rangement du pointeur dans la liste d'entiers adhoc
  137.         MLENT1.LECT(I)=MLREE1
  138.       ENDDO
  139. C
  140. C     Acquisition d'un CHPOINT ou d'un MCHAML en entree (MCHPO1/MCHEL1)
  141.       ICH=1
  142.       CALL LIROBJ('CHPOINT ',MCHPO1,0,IRETOU)
  143.       IF (IRETOU.EQ.1) THEN
  144.         CALL ACTOBJ('CHPOINT',MCHPO1,1)
  145.       ELSE
  146.         CALL LIROBJ('MCHAML',MCHEL1,0,IRETOU)
  147.         IF (IRETOU.EQ.1) THEN
  148.           ICH=2
  149.           CALL ACTOBJ('MCHAML  ',MCHEL1,1)
  150.         ELSE
  151.           CALL ERREUR(686)
  152.           RETURN
  153.         ENDIF
  154.       ENDIF
  155. C
  156. C     ----------------
  157. C     CAS D'UN CHPOINT
  158. C     ----------------
  159.       IF (ICH.EQ.1) THEN
  160. C       Initialisation du champ de sortie (MCHPO2) sur la base de
  161. C       celui d'entree, il possede les memes sous champs
  162.         SEGINI,MCHPO2=MCHPO1
  163.         MCHPO2.MOCHDE='CHPOINT interpole'
  164. C       Boucle sur les sous champs (MSOUP1) du CHPOINT d'entree
  165.         NBSOUS=MCHPO1.IPCHP(/1)
  166.         DO I=1,NBSOUS
  167.           MSOUP1=MCHPO1.IPCHP(I)
  168.           NCOMP1=MSOUP1.NOCOMP(/2)
  169. C         Verification que le CHPOINT contienne bien NDIM composantes
  170.           IF (NCOMP1.NE.NDIM) THEN
  171.             MOTERR(1:8)='CHPOINT '
  172.             CALL ERREUR(980)
  173.             RETURN
  174.           ENDIF
  175. C         Liste de correpondance entre les composantes du CHPOINT et les
  176. C         noms des dimensions de la grille
  177. C         MLENT2.LECT(i) = numero de la composante de MSOUP1
  178. C                          correspondante a la dimension i de la grille
  179.           JG=NCOMP1
  180.           SEGINI,MLENT2
  181.           DO J=1,NCOMP1
  182.             MOT1=MSOUP1.NOCOMP(J)
  183.             JVAL1=0
  184.             DO K=1,NDIM
  185.               MOT2=MLMOT1.MOTS(K)
  186.               IF (MOT1.EQ.MOT2) THEN
  187.                 JVAL1=K
  188.                 GOTO 1
  189.               ENDIF
  190.             ENDDO
  191. C           Cas ou une composante du CHPOINT ne se retrouve pas dans les
  192. C           noms des dimensions de la grille
  193.  1          IF (JVAL1.EQ.0) THEN
  194.               CALL ERREUR(665)
  195.               RETURN
  196.             ENDIF
  197.             MLENT2.LECT(JVAL1)=J
  198.           ENDDO
  199.           MPOVA1=MSOUP1.IPOVAL
  200. C         Initialisation des sous champs de sortie (MSOUP2)
  201. C         - ils sont definits sur les meme noeuds
  202. C         - ils ne possedent qu'une seule composante
  203.           NC=1
  204.           SEGINI,MSOUP2
  205.           MSOUP2.NOCOMP(1)=MLMOT1.MOTS(NDIM+1)
  206.           MSOUP2.IGEOC=MSOUP1.IGEOC
  207. C         On le range aussitot dans le CHPOINT global
  208.           MCHPO2.IPCHP(I)=MSOUP2
  209. C         Initialisation du tableau de valeurs (MPOVA2) du sous champ de
  210. C         sortie
  211.           N =MPOVA1.VPOCHA(/1)
  212.           NC=1
  213.           SEGINI,MPOVA2
  214. C         Preparation pour le calcul en parallele
  215.  
  216. C         Regalge fait sur PC40 pour determiner le nombre de NOEUDS optimum
  217. C         par thread
  218.           IOPTIM = 100
  219.           N1 = N / IOPTIM
  220.  
  221.           ITH = 0
  222.           IF (NBESC .NE. 0 ) ith=oothrd
  223.  
  224.  
  225.           IF ((N1.LE.1) .OR. (NBTHRS .EQ. 1) .OR. (ITH .GT. 0)) THEN
  226.             NBTHR = 1
  227.             BTHRD = .FALSE.
  228.           ELSE
  229.             BTHRD = .TRUE.
  230.             NBTHR = MIN(N1, NBTHRS)
  231.             CALL THREADII
  232.           ENDIF
  233.  
  234.           SEGINI,SPARAL
  235.           DO ITH=1,NBTHR
  236.             SEGINI,SXX
  237.             SPARAL.IXX(ITH) = SXX
  238.           ENDDO
  239.  
  240.           SPARAL.NNN    = N
  241.           SPARAL.ML1    = MLENT1
  242.           SPARAL.ML2    = MLENT2
  243.           SPARAL.MPV1   = MPOVA1
  244.           SPARAL.MPV2   = MPOVA2
  245.           SPARAL.MCH1   = 0
  246.           SPARAL.MEL2   = 0
  247.           SPARAL.N1EL1  = 0
  248.           SPARAL.N1PEL1 = 0
  249.  
  250. C         Lancement des Threads
  251.           IF (BTHRD) THEN
  252.             IPARAL = SPARAL
  253.             DO ITH=2,NBTHR
  254.               CALL THREADID(ITH,IPMULi)
  255.             ENDDO
  256.             CALL IPMULi(1)
  257.  
  258.             DO ITH=2,NBTHR
  259.               CALL THREADIF(ITH)
  260.             ENDDO
  261.  
  262.             CALL THREADIS
  263.           ELSE
  264.             CALL IPMUL0(1,SPARAL)
  265.           ENDIF
  266.           MSOUP2.IPOVAL=MPOVA2
  267.           DO ITH=1,NBTHR
  268.             SXX = SPARAL.IXX(ITH)
  269.             SEGSUP,SXX
  270.           ENDDO
  271.           SEGSUP,MLENT2,SPARAL
  272.         ENDDO
  273.         SEGSUP,MLMOT1,MLENT1
  274. C       Ecriture du CHPOINT de sortie dans la pile
  275.         CALL ECROBJ('CHPOINT ',MCHPO2)
  276. C
  277. C     ---------------
  278. C     CAS D'UN MCHAML
  279. C     ---------------
  280.       ELSEIF(ICH.EQ.2) THEN
  281. C       Initialisation du champ de sortie (MCHEL2) sur la base de
  282. C       celui d'entree, il possede les memes sous zones
  283.         SEGINI,MCHEL2=MCHEL1
  284.         MCHEL2.TITCHE='MCHAML interpole'
  285. C       Boucle sur les sous zones (MCHAM1) du MCHAML d'entree
  286.         NBSOUS=MCHEL1.ICHAML(/1)
  287.         DO I=1,NBSOUS
  288.           MCHAM1=MCHEL1.ICHAML(I)
  289. C         Initialisation des sous zones de sortie (MCHAM2)
  290. C           - elles ne possedent qu'une seule composante de type
  291. C             flottant
  292.           N2=1
  293.           SEGINI,MCHAM2
  294.           MCHAM2.NOMCHE(1)=MLMOT1.MOTS(NDIM+1)
  295.           MCHAM2.TYPCHE(1)='REAL*8'
  296. C         On le range aussitot dans le MCHAML global
  297.           MCHEL2.ICHAML(I)=MCHAM2
  298. C         Verification que le MCHAML de cettre sous zone contienne bien
  299. C         NDIM composantes
  300.           NCOMP1=MCHAM1.NOMCHE(/2)
  301.           IF (NCOMP1.NE.NDIM) THEN
  302.             MOTERR(1:8)='MCHAML  '
  303.             CALL ERREUR(980)
  304.             RETURN
  305.           ENDIF
  306. C         Liste de correpondance entre les composantes du MCHAML et les
  307. C         noms des dimensions de la grille
  308. C         MLENT2.LECT(i) = numero de la composante de MCHAM1
  309. C                          correspondante a la dimension i de la grille
  310.           JG=NCOMP1
  311.           SEGINI,MLENT2
  312.           N1PTEL=0
  313.           N1EL=0
  314.           N2PTEL=0
  315.           N2EL=0
  316.           DO J=1,NCOMP1
  317.             MOT1=MCHAM1.NOMCHE(J)
  318.             JVAL1=0
  319.             DO K=1,NDIM
  320.               MOT2=MLMOT1.MOTS(K)
  321.               IF (MOT1.EQ.MOT2) THEN
  322.                 JVAL1=K
  323.                 GOTO 2
  324.               ENDIF
  325.             ENDDO
  326. C           Cas ou une composante du MCHAML ne se retrouve pas dans les
  327. C           noms des dimensions de la grille
  328.  2          IF (JVAL1.EQ.0) THEN
  329.               CALL ERREUR(665)
  330.               RETURN
  331.             ENDIF
  332.             MLENT2.LECT(JVAL1)=J
  333. C           Verification que le champ contient des flottants,
  334.             IF (MCHAM1.TYPCHE(J).NE.'REAL*8') THEN
  335.               MOTERR(1:16)  = MCHAM1.TYPCHE(J)
  336.               MOTERR(17:20) = MOT1(1:4)
  337.               MOTERR(21:29) = 'argument'
  338.               CALL ERREUR(552)
  339.               RETURN
  340.             ENDIF
  341. C           Recherche des tailles MAX des MELVAL de chaque composante de
  342. C           cette sous zone (pour preparer le champ de sortie)
  343.             MELVA1=MCHAM1.IELVAL(J)
  344.             N1PTEL=MAX(N1PTEL,MELVA1.VELCHE(/1))
  345.             N1EL  =MAX(N1EL  ,MELVA1.VELCHE(/2))
  346.           ENDDO
  347. C         Initialisation du tableau de valeurs (MELVA2) du sous champ
  348. C         de sortie
  349.           SEGINI,MELVA2
  350. C         Preparation pour le calcul en parallele
  351. C         Regalge fait sur PC40 pour determiner le nombre de NOEUDS optimum
  352. C         par thread
  353.           IOPTIM = 100
  354.           N1 = N1EL / IOPTIM
  355.  
  356.           ITH = 0
  357.           IF (NBESC .NE. 0 ) ith=oothrd
  358. C         CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  359. C                    DEJA DANS LES ASSISTANTS
  360.           IF ((N1.LE.1) .OR. (NBTHRS .EQ. 1) .OR. (ITH .GT. 0)) THEN
  361.             NBTHR = 1
  362.             BTHRD = .FALSE.
  363.           ELSE
  364.             BTHRD = .TRUE.
  365.             NBTHR = MIN(N1, NBTHRS)
  366.             CALL THREADII
  367.           ENDIF
  368.  
  369.           SEGINI,SPARAL
  370.           DO ITH=1,NBTHR
  371.             SEGINI,SXX
  372.             SPARAL.IXX(ITH) = SXX
  373.           ENDDO
  374.  
  375.           SPARAL.NNN    = 0
  376.           SPARAL.ML1    = MLENT1
  377.           SPARAL.ML2    = MLENT2
  378.           SPARAL.MPV1   = 0
  379.           SPARAL.MPV2   = 0
  380.           SPARAL.MCH1   = MCHAM1
  381.           SPARAL.MEL2   = MELVA2
  382.           SPARAL.N1EL1  = N1EL
  383.           SPARAL.N1PEL1 = N1PTEL
  384.  
  385. C         Lancement des Threads
  386.           IF ((nbthr.gt.1) .AND. BTHRD) THEN
  387.             IPARAL = SPARAL
  388.             DO ITH=2,NBTHR
  389.               CALL THREADID(ITH,IPMULi)
  390.             ENDDO
  391.             CALL IPMULi(1)
  392.  
  393.             DO ITH=2,NBTHR
  394.               CALL THREADIF(ITH)
  395.             ENDDO
  396.  
  397.             CALL THREADIS
  398.           ELSE
  399.             CALL IPMUL0(1,SPARAL)
  400.           ENDIF
  401.           MCHAM2.IELVAL(1)=MELVA2
  402.  
  403.           DO ITH=1,NBTHR
  404.             SXX = SPARAL.IXX(ITH)
  405.             SEGSUP,SXX
  406.           ENDDO
  407.           SEGSUP,MLENT2,SPARAL
  408.         ENDDO
  409. C       Ecriture du MCHAML de sortie dans la pile
  410.         CALL ACTOBJ('MCHAML  ',MCHEL2,1)
  411.         CALL ECROBJ('MCHAML  ',MCHEL2)
  412.       ENDIF
  413.  
  414.       END
  415.  
  416.  
  417.  
  418.  
  419.  
  420.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales