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

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