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. -INC CCOPTIO
  43. -INC SMNUAGE
  44. -INC SMCHPOI
  45. -INC SMCHAML
  46. -INC SMLREEL
  47. -INC SMLENTI
  48. -INC SMLMOTS
  49. -INC CCASSIS
  50. CHARACTER*8 MOT1,MOT2
  51. LOGICAL BTHRD
  52.  
  53. SEGMENT SPARAL
  54. INTEGER NNN,ML1,ML2,MPV1,MPV2,MCH1,MEL2,
  55. & N1EL1,N1PEL1
  56. INTEGER IXX(NBTHR)
  57. ENDSEGMENT
  58.  
  59. SEGMENT SXX
  60. REAL*8 XX(NDIM)
  61. ENDSEGMENT
  62.  
  63. C
  64. C Introduction d'un COMMON pour la parallelisation
  65. COMMON/IPLMUC/IPARAL
  66.  
  67. EXTERNAL IPMULi
  68.  
  69. C
  70. C Pour la paralelisation de l'interpolation
  71. C
  72. BTHRD = .FALSE.
  73. IPARAL= 0
  74. C
  75. C
  76. C Depouillement du nuage pour connaitre le nombre de dimensions de
  77. C la grille
  78. MNUAG1=INUA
  79. SEGACT,MNUAG1
  80. NNU=MNUAG1.NUAPOI(/1)
  81. NDIM=NNU-1
  82. IF (NDIM.LT.1) THEN
  83. INTERR(1)=MNUAG1
  84. INTERR(2)=2
  85. INTERR(3)=1
  86. CALL ERREUR(628)
  87. RETURN
  88. ENDIF
  89. C
  90. C Initialisation d'une liste de mots pour stocker les noms des
  91. C dimensions de la grille
  92. JGN=4
  93. JGM=NNU
  94. SEGINI,MLMOT1
  95. C
  96. C Iniilisation d'une liste d'entiers pour stocker les pointeurs vers
  97. C les LISTREEL definissant la grille de valeur de la fonction F
  98. JG=NNU
  99. SEGINI,MLENT1
  100. C
  101. C Parcours du NUAGE pour verifications
  102. NVAL=1
  103. DO I=1,NNU
  104. C Nom de la composante I
  105. MOT1=MNUAG1.NUANOM(I)
  106. C Et rangement du mot dans la liste de mots adhoc
  107. MLMOT1.MOTS(I)=MOT1
  108. C Les composantes doivent abriter 1 seul objet de type LISTREEL
  109. MOT2=MNUAG1.NUATYP(I)
  110. IF (MOT2.NE.'LISTREEL') THEN
  111. CALL ERREUR(941)
  112. RETURN
  113. ENDIF
  114. NUAVI1=MNUAG1.NUAPOI(I)
  115. SEGACT,NUAVI1
  116. NPO=NUAVI1.NUAINT(/1)
  117. IF (NPO.NE.1) THEN
  118. CALL ERREUR(941)
  119. RETURN
  120. ENDIF
  121. MLREE1=NUAVI1.NUAINT(1)
  122. C Verification de la taille de la derniere liste
  123. SEGACT,MLREE1
  124. IF (I.EQ.NNU) THEN
  125. NTEST=MLREE1.PROG(/1)
  126. IF (NTEST.NE.NVAL) THEN
  127. CALL ERREUR(21)
  128. RETURN
  129. ENDIF
  130. ELSE
  131. NVAL=NVAL*(MLREE1.PROG(/1))
  132. ENDIF
  133. C Et rangement du pointeur dans la liste d'entiers adhoc
  134. MLENT1.LECT(I)=MLREE1
  135. ENDDO
  136. C
  137. C Acquisition d'un CHPOINT ou d'un MCHAML en entree (MCHPO1/MCHEL1)
  138. ICH=1
  139. CALL LIROBJ('CHPOINT',MCHPO1,0,IRETOU)
  140. IF (IRETOU.EQ.1) THEN
  141. SEGACT,MCHPO1
  142. ELSE
  143. CALL LIROBJ('MCHAML',MCHEL1,0,IRETOU)
  144. IF (IRETOU.EQ.1) THEN
  145. ICH=2
  146. SEGACT,MCHEL1
  147. ELSE
  148. CALL ERREUR(686)
  149. RETURN
  150. ENDIF
  151. ENDIF
  152. C
  153. C ----------------
  154. C CAS D'UN CHPOINT
  155. C ----------------
  156. IF (ICH.EQ.1) THEN
  157. C Initialisation du champ de sortie (MCHPO2) sur la base de
  158. C celui d'entree, il possede les memes sous champs
  159. SEGINI,MCHPO2=MCHPO1
  160. MCHPO2.MOCHDE='CHPOINT interpole'
  161. C Boucle sur les sous champs (MSOUP1) du CHPOINT d'entree
  162. NBSOUS=MCHPO1.IPCHP(/1)
  163. DO I=1,NBSOUS
  164. MSOUP1=MCHPO1.IPCHP(I)
  165. SEGACT,MSOUP1
  166. NCOMP1=MSOUP1.NOCOMP(/2)
  167. C Verification que le CHPOINT contienne bien NDIM composantes
  168. IF (NCOMP1.NE.NDIM) THEN
  169. MOTERR(1:8)='CHPOINT '
  170. CALL ERREUR(980)
  171. RETURN
  172. ENDIF
  173. C Liste de correpondance entre les composantes du CHPOINT et les
  174. C noms des dimensions de la grille
  175. C MLENT2.LECT(i) = numero de la composante de MSOUP1
  176. C correspondante a la dimension i de la grille
  177. JG=NCOMP1
  178. SEGINI,MLENT2
  179. DO J=1,NCOMP1
  180. MOT1=MSOUP1.NOCOMP(J)
  181. JVAL1=0
  182. DO K=1,NDIM
  183. MOT2=MLMOT1.MOTS(K)
  184. IF (MOT1.EQ.MOT2) THEN
  185. JVAL1=K
  186. GOTO 1
  187. ENDIF
  188. ENDDO
  189. C Cas ou une composante du CHPOINT ne se retrouve pas dans les
  190. C noms des dimensions de la grille
  191. 1 IF (JVAL1.EQ.0) THEN
  192. CALL ERREUR(665)
  193. RETURN
  194. ENDIF
  195. MLENT2.LECT(JVAL1)=J
  196. ENDDO
  197. MPOVA1=MSOUP1.IPOVAL
  198. SEGACT,MPOVA1
  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. SEGACT,MCHAM1
  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 Activation des MELVA1 pour parallelisme
  307. DO J=1,NDIM
  308. MELVA1=MCHAM1.IELVAL(J)
  309. SEGACT,MELVA1
  310. ENDDO
  311. C Liste de correpondance entre les composantes du MCHAML et les
  312. C noms des dimensions de la grille
  313. C MLENT2.LECT(i) = numero de la composante de MCHAM1
  314. C correspondante a la dimension i de la grille
  315. JG=NCOMP1
  316. SEGINI,MLENT2
  317. N1PTEL=0
  318. N1EL=0
  319. N2PTEL=0
  320. N2EL=0
  321. DO J=1,NCOMP1
  322. MOT1=MCHAM1.NOMCHE(J)
  323. JVAL1=0
  324. DO K=1,NDIM
  325. MOT2=MLMOT1.MOTS(K)
  326. IF (MOT1.EQ.MOT2) THEN
  327. JVAL1=K
  328. GOTO 2
  329. ENDIF
  330. ENDDO
  331. C Cas ou une composante du MCHAML ne se retrouve pas dans les
  332. C noms des dimensions de la grille
  333. 2 IF (JVAL1.EQ.0) THEN
  334. CALL ERREUR(665)
  335. RETURN
  336. ENDIF
  337. MLENT2.LECT(JVAL1)=J
  338. C Verification que le champ contient des flottants,
  339. IF (MCHAM1.TYPCHE(J).NE.'REAL*8') THEN
  340. MOTERR(1:16) = MCHAM1.TYPCHE(J)
  341. MOTERR(17:20) = MOT1(1:4)
  342. MOTERR(21:29) = 'argument'
  343. CALL ERREUR(552)
  344. RETURN
  345. ENDIF
  346. C Recherche des tailles MAX des MELVAL de chaque composante de
  347. C cette sous zone (pour preparer le champ de sortie)
  348. MELVA1=MCHAM1.IELVAL(J)
  349. SEGACT,MELVA1
  350. N1PTEL=MAX(N1PTEL,MELVA1.VELCHE(/1))
  351. N1EL =MAX(N1EL ,MELVA1.VELCHE(/2))
  352. ENDDO
  353. C Initialisation du tableau de valeurs (MELVA2) du sous champ
  354. C de sortie
  355. SEGINI,MELVA2
  356. C Preparation pour le calcul en parallele
  357. C Regalge fait sur PC40 pour determiner le nombre de NOEUDS optimum
  358. C par thread
  359. IOPTIM = 100
  360. N1 = N1EL / IOPTIM
  361.  
  362. ITH = 0
  363. IF (NBESC .NE. 0 ) ith=oothrd
  364. C CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  365. C DEJA DANS LES ASSISTANTS
  366. IF ((N1.LE.1) .OR. (NBTHRS .EQ. 1) .OR. (ITH .GT. 0)) THEN
  367. NBTHR = 1
  368. BTHRD = .FALSE.
  369. ELSE
  370. BTHRD = .TRUE.
  371. NBTHR = MIN(N1, NBTHRS)
  372. CALL THREADII
  373. ENDIF
  374.  
  375. SEGINI,SPARAL
  376. DO ITH=1,NBTHR
  377. SEGINI,SXX
  378. SPARAL.IXX(ITH) = SXX
  379. ENDDO
  380.  
  381. SPARAL.NNN = 0
  382. SPARAL.ML1 = MLENT1
  383. SPARAL.ML2 = MLENT2
  384. SPARAL.MPV1 = 0
  385. SPARAL.MPV2 = 0
  386. SPARAL.MCH1 = MCHAM1
  387. SPARAL.MEL2 = MELVA2
  388. SPARAL.N1EL1 = N1EL
  389. SPARAL.N1PEL1 = N1PTEL
  390.  
  391. C Lancement des Threads
  392. IF ((nbthr.gt.1) .AND. BTHRD) THEN
  393. IPARAL = SPARAL
  394. DO ITH=2,NBTHR
  395. CALL THREADID(ITH,IPMULi)
  396. ENDDO
  397. CALL IPMULi(1)
  398.  
  399. DO ITH=2,NBTHR
  400. CALL THREADIF(ITH)
  401. ENDDO
  402.  
  403. CALL THREADIS
  404. ELSE
  405. CALL IPMUL0(1,SPARAL)
  406. ENDIF
  407. MCHAM2.IELVAL(1)=MELVA2
  408. C Desactivation des MELVA1 pour parallelisme
  409. DO J=1,NDIM
  410. MELVA1=MCHAM1.IELVAL(J)
  411. SEGACT,MELVA1
  412. ENDDO
  413.  
  414. DO ITH=1,NBTHR
  415. SXX = SPARAL.IXX(ITH)
  416. SEGSUP,SXX
  417. ENDDO
  418. SEGSUP,MLENT2,SPARAL
  419. ENDDO
  420. C Ecriture du MCHAML de sortie dans la pile
  421. CALL ACTOBJ('MCHAML ',MCHEL2,1)
  422. CALL ECROBJ('MCHAML ',MCHEL2)
  423. ENDIF
  424.  
  425. END
  426.  
  427.  
  428.  

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