Télécharger ipgril.eso

Retour à la liste

Numérotation des lignes :

  1. C IPGRIL SOURCE CB215821 19/07/30 21:16:57 10273
  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*8 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=4
  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. SEGACT,MCHPO1
  144. ELSE
  145. CALL LIROBJ('MCHAML',MCHEL1,0,IRETOU)
  146. IF (IRETOU.EQ.1) THEN
  147. ICH=2
  148. SEGACT,MCHEL1
  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. SEGACT,MSOUP1
  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. SEGACT,MPOVA1
  201. C Initialisation des sous champs de sortie (MSOUP2)
  202. C - ils sont definits sur les meme noeuds
  203. C - ils ne possedent qu'une seule composante
  204. NC=1
  205. SEGINI,MSOUP2
  206. MSOUP2.NOCOMP(1)=MLMOT1.MOTS(NDIM+1)
  207. MSOUP2.IGEOC=MSOUP1.IGEOC
  208. C On le range aussitot dans le CHPOINT global
  209. MCHPO2.IPCHP(I)=MSOUP2
  210. C Initialisation du tableau de valeurs (MPOVA2) du sous champ de
  211. C sortie
  212. N =MPOVA1.VPOCHA(/1)
  213. NC=1
  214. SEGINI,MPOVA2
  215. C Preparation pour le calcul en parallele
  216.  
  217. C Regalge fait sur PC40 pour determiner le nombre de NOEUDS optimum
  218. C par thread
  219. IOPTIM = 100
  220. N1 = N / IOPTIM
  221.  
  222. ITH = 0
  223. IF (NBESC .NE. 0 ) ith=oothrd
  224.  
  225.  
  226. IF ((N1.LE.1) .OR. (NBTHRS .EQ. 1) .OR. (ITH .GT. 0)) THEN
  227. NBTHR = 1
  228. BTHRD = .FALSE.
  229. ELSE
  230. BTHRD = .TRUE.
  231. NBTHR = MIN(N1, NBTHRS)
  232. CALL THREADII
  233. ENDIF
  234.  
  235. SEGINI,SPARAL
  236. DO ITH=1,NBTHR
  237. SEGINI,SXX
  238. SPARAL.IXX(ITH) = SXX
  239. ENDDO
  240.  
  241. SPARAL.NNN = N
  242. SPARAL.ML1 = MLENT1
  243. SPARAL.ML2 = MLENT2
  244. SPARAL.MPV1 = MPOVA1
  245. SPARAL.MPV2 = MPOVA2
  246. SPARAL.MCH1 = 0
  247. SPARAL.MEL2 = 0
  248. SPARAL.N1EL1 = 0
  249. SPARAL.N1PEL1 = 0
  250.  
  251. C Lancement des Threads
  252. IF (BTHRD) THEN
  253. IPARAL = SPARAL
  254. DO ITH=2,NBTHR
  255. CALL THREADID(ITH,IPMULi)
  256. ENDDO
  257. CALL IPMULi(1)
  258.  
  259. DO ITH=2,NBTHR
  260. CALL THREADIF(ITH)
  261. ENDDO
  262.  
  263. CALL THREADIS
  264. ELSE
  265. CALL IPMUL0(1,SPARAL)
  266. ENDIF
  267. MSOUP2.IPOVAL=MPOVA2
  268. DO ITH=1,NBTHR
  269. SXX = SPARAL.IXX(ITH)
  270. SEGSUP,SXX
  271. ENDDO
  272. SEGSUP,MLENT2,SPARAL
  273. ENDDO
  274. SEGSUP,MLMOT1,MLENT1
  275. C Ecriture du CHPOINT de sortie dans la pile
  276. CALL ECROBJ('CHPOINT ',MCHPO2)
  277. C
  278. C ---------------
  279. C CAS D'UN MCHAML
  280. C ---------------
  281. ELSEIF(ICH.EQ.2) THEN
  282. C Initialisation du champ de sortie (MCHEL2) sur la base de
  283. C celui d'entree, il possede les memes sous zones
  284. SEGINI,MCHEL2=MCHEL1
  285. MCHEL2.TITCHE='MCHAML interpole'
  286. C Boucle sur les sous zones (MCHAM1) du MCHAML d'entree
  287. NBSOUS=MCHEL1.ICHAML(/1)
  288. DO I=1,NBSOUS
  289. MCHAM1=MCHEL1.ICHAML(I)
  290. SEGACT,MCHAM1
  291. C Initialisation des sous zones de sortie (MCHAM2)
  292. C - elles ne possedent qu'une seule composante de type
  293. C flottant
  294. N2=1
  295. SEGINI,MCHAM2
  296. MCHAM2.NOMCHE(1)=MLMOT1.MOTS(NDIM+1)
  297. MCHAM2.TYPCHE(1)='REAL*8'
  298. C On le range aussitot dans le MCHAML global
  299. MCHEL2.ICHAML(I)=MCHAM2
  300. C Verification que le MCHAML de cettre sous zone contienne bien
  301. C NDIM composantes
  302. NCOMP1=MCHAM1.NOMCHE(/2)
  303. IF (NCOMP1.NE.NDIM) THEN
  304. MOTERR(1:8)='MCHAML '
  305. CALL ERREUR(980)
  306. RETURN
  307. ENDIF
  308. C Activation des MELVA1 pour parallelisme
  309. DO J=1,NDIM
  310. MELVA1=MCHAM1.IELVAL(J)
  311. SEGACT,MELVA1
  312. ENDDO
  313. C Liste de correpondance entre les composantes du MCHAML et les
  314. C noms des dimensions de la grille
  315. C MLENT2.LECT(i) = numero de la composante de MCHAM1
  316. C correspondante a la dimension i de la grille
  317. JG=NCOMP1
  318. SEGINI,MLENT2
  319. N1PTEL=0
  320. N1EL=0
  321. N2PTEL=0
  322. N2EL=0
  323. DO J=1,NCOMP1
  324. MOT1=MCHAM1.NOMCHE(J)
  325. JVAL1=0
  326. DO K=1,NDIM
  327. MOT2=MLMOT1.MOTS(K)
  328. IF (MOT1.EQ.MOT2) THEN
  329. JVAL1=K
  330. GOTO 2
  331. ENDIF
  332. ENDDO
  333. C Cas ou une composante du MCHAML ne se retrouve pas dans les
  334. C noms des dimensions de la grille
  335. 2 IF (JVAL1.EQ.0) THEN
  336. CALL ERREUR(665)
  337. RETURN
  338. ENDIF
  339. MLENT2.LECT(JVAL1)=J
  340. C Verification que le champ contient des flottants,
  341. IF (MCHAM1.TYPCHE(J).NE.'REAL*8') THEN
  342. MOTERR(1:16) = MCHAM1.TYPCHE(J)
  343. MOTERR(17:20) = MOT1(1:4)
  344. MOTERR(21:29) = 'argument'
  345. CALL ERREUR(552)
  346. RETURN
  347. ENDIF
  348. C Recherche des tailles MAX des MELVAL de chaque composante de
  349. C cette sous zone (pour preparer le champ de sortie)
  350. MELVA1=MCHAM1.IELVAL(J)
  351. SEGACT,MELVA1
  352. N1PTEL=MAX(N1PTEL,MELVA1.VELCHE(/1))
  353. N1EL =MAX(N1EL ,MELVA1.VELCHE(/2))
  354. ENDDO
  355. C Initialisation du tableau de valeurs (MELVA2) du sous champ
  356. C de sortie
  357. SEGINI,MELVA2
  358. C Preparation pour le calcul en parallele
  359. C Regalge fait sur PC40 pour determiner le nombre de NOEUDS optimum
  360. C par thread
  361. IOPTIM = 100
  362. N1 = N1EL / IOPTIM
  363.  
  364. ITH = 0
  365. IF (NBESC .NE. 0 ) ith=oothrd
  366. C CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  367. C DEJA DANS LES ASSISTANTS
  368. IF ((N1.LE.1) .OR. (NBTHRS .EQ. 1) .OR. (ITH .GT. 0)) THEN
  369. NBTHR = 1
  370. BTHRD = .FALSE.
  371. ELSE
  372. BTHRD = .TRUE.
  373. NBTHR = MIN(N1, NBTHRS)
  374. CALL THREADII
  375. ENDIF
  376.  
  377. SEGINI,SPARAL
  378. DO ITH=1,NBTHR
  379. SEGINI,SXX
  380. SPARAL.IXX(ITH) = SXX
  381. ENDDO
  382.  
  383. SPARAL.NNN = 0
  384. SPARAL.ML1 = MLENT1
  385. SPARAL.ML2 = MLENT2
  386. SPARAL.MPV1 = 0
  387. SPARAL.MPV2 = 0
  388. SPARAL.MCH1 = MCHAM1
  389. SPARAL.MEL2 = MELVA2
  390. SPARAL.N1EL1 = N1EL
  391. SPARAL.N1PEL1 = N1PTEL
  392.  
  393. C Lancement des Threads
  394. IF ((nbthr.gt.1) .AND. BTHRD) THEN
  395. IPARAL = SPARAL
  396. DO ITH=2,NBTHR
  397. CALL THREADID(ITH,IPMULi)
  398. ENDDO
  399. CALL IPMULi(1)
  400.  
  401. DO ITH=2,NBTHR
  402. CALL THREADIF(ITH)
  403. ENDDO
  404.  
  405. CALL THREADIS
  406. ELSE
  407. CALL IPMUL0(1,SPARAL)
  408. ENDIF
  409. MCHAM2.IELVAL(1)=MELVA2
  410. C Desactivation des MELVA1 pour parallelisme
  411. DO J=1,NDIM
  412. MELVA1=MCHAM1.IELVAL(J)
  413. SEGACT,MELVA1
  414. ENDDO
  415.  
  416. DO ITH=1,NBTHR
  417. SXX = SPARAL.IXX(ITH)
  418. SEGSUP,SXX
  419. ENDDO
  420. SEGSUP,MLENT2,SPARAL
  421. ENDDO
  422. C Ecriture du MCHAML de sortie dans la pile
  423. CALL ACTOBJ('MCHAML ',MCHEL2,1)
  424. CALL ECROBJ('MCHAML ',MCHEL2)
  425. ENDIF
  426.  
  427. END
  428.  
  429.  
  430.  

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