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