Télécharger fuchpo.eso

Retour à la liste

Numérotation des lignes :

fuchpo
  1. C FUCHPO SOURCE FANDEUR 22/01/19 21:15:06 11256
  2. SUBROUTINE FUCHPO(IP1,IP2,IRET)
  3. C======================================================================
  4. C fonction:
  5. C sous routine pour fusionner deux champs par points diffus
  6. C
  7. C arguments:
  8. C ip1 (E) pointeur sur le premier des deux champ par point
  9. C ip2 (E) pointeur sur le second des deux champ par point
  10. C iret (S) pointeur sur le champ par point resultat
  11. C
  12. C variables:
  13. C
  14. C * mtrav : - bb(i,j) est la valeur de la ieme inconnue de champ pour
  15. C le jieme noeud du tableau igeo .
  16. C - inco(nnin) contient le nom des nnin inconnues differentes
  17. C - ibin(i,j)=1 ou 0 indique que la ieme inconnue du champ
  18. C existe pour le jieme noeud du tableau igeo .
  19. C - igeo(i) est le numero a mettre dans un objet meleme pour
  20. C referencer le ieme noeud .
  21. C
  22. C * mtra : - nopoin(i) adresse de colonne dans bb et ibin des valeurs
  23. C correspondant au noeud i .
  24. C
  25. C * mtr1 : - ipcom liste des noms des inconnues permet de creer inco .
  26. C
  27. C * mtr2 : - iicom adresse dans ipcom des inconnues correspondant au
  28. C 2ieme ch point .
  29. C
  30. C * mtr3 : - index tableau de correspondance entre les supports geome-
  31. C triques du 1er chpoint et du 2ieme chpoint .
  32. C
  33. C auteur: A de Gayffier 13/06/94
  34. C======================================================================
  35. IMPLICIT INTEGER(I-N)
  36. IMPLICIT REAL*8(A-H,O-Z)
  37. -INC SMCHPOI
  38.  
  39. -INC PPARAM
  40. -INC CCOPTIO
  41. -INC SMELEME
  42. -INC SMCOORD
  43. -INC TMTRAV
  44. SEGMENT/MTRA/(NOPOIN(nbpts))
  45. SEGMENT MTR1
  46. CHARACTER*(LOCOMP) IPCOM(0)
  47. ENDSEGMENT
  48. SEGMENT/MTR2/(IICOM(0))
  49. SEGMENT/MTR3/(INDEX(0))
  50. SEGMENT/MTR4/(IPHAR(0))
  51. C ordre de grandeur des composantes
  52. SEGMENT/MTR5/(DMOY(NNIN))
  53. C
  54. DIMENSION IPO(2)
  55. CHARACTER*8 MOT
  56. DATA UN,ZERO/1.D0,0.D0/
  57. character*4 mcle(1)
  58. data mcle/'NOER'/
  59. C
  60. IRET = 0
  61.  
  62. noer=0
  63. call lirmot(mcle,1,noer,0)
  64. if (ierr.ne.0) return
  65.  
  66. MCHPO1 = IP1
  67. MCHPO2 = IP2
  68. SEGACT,MCHPO1,MCHPO2
  69.  
  70. NSOUP1 = MCHPO1.IPCHP(/1)
  71. NSOUP2 = MCHPO2.IPCHP(/1)
  72.  
  73. NAT1 = MCHPO1.JATTRI(1)
  74. NAT2 = MCHPO2.JATTRI(1)
  75.  
  76. * Si CHPOINT vide, on renvoie l'autre si il est non vide:
  77. IF (NSOUP1.EQ.0) THEN
  78. IRET = MCHPO2
  79. RETURN
  80. ENDIF
  81. IF (NSOUP2.EQ.0) then
  82. IRET = MCHPO1
  83. RETURN
  84. ENDIF
  85. C
  86. C verification de la compatibilité des natures
  87. C
  88. IF ( (NAT1*NAT2) .EQ. 0) THEN
  89. C une des deux natures est indeterminée
  90. CALL ERREUR(650)
  91. RETURN
  92. ELSE
  93. IF ((NAT1 .EQ. 2) .AND. (NAT2 .EQ. 2)) THEN
  94. C les deux champ sont discrets: on somme les composantes communes
  95. CALL ADCHPO(IP1,IP2,IRET,1D0,1D0)
  96. RETURN
  97. ENDIF
  98. IF ((NAT1 .NE. 1) .OR. (NAT2 .NE. 1)) THEN
  99. C les natures ne sont pas compatibles
  100. CALL ERREUR(649)
  101. RETURN
  102. ENDIF
  103. ENDIF
  104. C
  105. C Petite verification sur les modes de calcul
  106. ifo1 = MCHPO1.IFOPOI
  107. ifo2 = MCHPO2.IFOPOI
  108. ifos = ifo1
  109. IF (ifo1 .NE. ifo2) THEN
  110. interr(1)=ifo1
  111. interr(2)=ifo2
  112. interr(3)=IFOUR
  113. c-dbg write(ioimp,*) '1132 FUCHPO',ip1,ip2
  114. call erreur(1132)
  115. ifos = IFOUR
  116. END IF
  117.  
  118. C les deux champs sont de nature diffuse
  119. C on moyenne les composantes communes
  120. C
  121. IF ( IP1 .NE. IP2) GOTO 60
  122. C
  123. C *** cas ou les 2 pointeurs ip1 et ip2 sont egaux
  124. C
  125. c* SEGACT MCHPO1
  126. NSOUPO=NSOUP1
  127. NAT =NAT1
  128. SEGINI MCHPOI
  129. DO 10 I=1,NAT
  130. JATTRI(I)=MCHPO1.JATTRI(I)
  131. 10 CONTINUE
  132. MOCHDE=MCHPO1.MOCHDE
  133. MTYPOI=MCHPO1.MTYPOI
  134. IFOPOI=ifos
  135. DO 50 IA=1,NSOUPO
  136. MSOUP1=MCHPO1.IPCHP(IA)
  137. SEGACT MSOUP1
  138. NC=MSOUP1.NOCOMP(/2)
  139. SEGINI MSOUPO
  140. IPCHP(IA)=MSOUPO
  141. DO 20 IB=1,NC
  142. NOCOMP(IB)=MSOUP1.NOCOMP(IB)
  143. NOHARM(IB)=MSOUP1.NOHARM(IB)
  144. 20 CONTINUE
  145. IGEOC=MSOUP1.IGEOC
  146. MPOVA1=MSOUP1.IPOVAL
  147. SEGACT MPOVA1
  148. N =MPOVA1.VPOCHA(/1)
  149. NC1=MPOVA1.VPOCHA(/2)
  150. C
  151. C erreur pb dimension tableau voir routine adchpo
  152. IF (NC1.NE.NC) THEN
  153. IRET=0
  154. SEGSUP MSOUPO,MCHPOI
  155. CALL ERREUR(114)
  156. RETURN
  157. ENDIF
  158. C
  159. SEGINI MPOVAL
  160. IPOVAL=MPOVAL
  161. DO 40 IC=1,NC
  162. DO 41 IB=1,N
  163. VPOCHA(IB,IC)=MPOVA1.VPOCHA(IB,IC)
  164. 41 CONTINUE
  165. 40 CONTINUE
  166. 50 CONTINUE
  167. C
  168. C on sort de la sous routine
  169. IRET=MCHPOI
  170. GOTO 666
  171. C
  172. C *** cas ou les pointeurs ip1 et ip2 sont differents
  173. C
  174. 60 CONTINUE
  175. IPO(1)=IP1
  176. IPO(2)=IP2
  177. MOT=MCHPO1.MTYPOI
  178. IF(MOT.NE.MCHPO2.MTYPOI) THEN
  179. MOT='ET OU +'
  180. ENDIF
  181. C
  182. C on verifie que les nbres de sous paquets sont egaux
  183. C
  184. IF(NSOUP1.EQ.NSOUP2) GO TO 75
  185. C traitement par la methode générale
  186. GO TO 300
  187. C
  188. C on regarde si les supports geometriques sont identiques a une
  189. C permutation pres
  190. C
  191. 75 SEGINI MTR3
  192. DO 100 IA=1,NSOUP1
  193. MSOUP1=MCHPO1.IPCHP(IA)
  194. SEGACT MSOUP1
  195. DO 80 IB=1,NSOUP2
  196. MSOUP2=MCHPO2.IPCHP(IB)
  197. SEGACT MSOUP2
  198. IF(MSOUP1.IGEOC.EQ.MSOUP2.IGEOC) GO TO 90
  199. 80 CONTINUE
  200. C
  201. C il n y a pas egalite des supports geometriques a une permutation
  202. C pres
  203. C
  204. SEGSUP MTR3
  205. C traitement par la methode générale
  206. GO TO 300
  207. C
  208. 90 CONTINUE
  209. C la permutation est rangée dans index
  210. INDEX(**)=IB
  211. 100 CONTINUE
  212. C
  213. C *** cas ou il y a egalite des supports geometriques a une permutation
  214. C pres
  215. C
  216. NSOUPO=NSOUP1
  217. NAT=MAX(NAT1,NAT2,1)
  218. SEGINI MCHPOI
  219. JATTRI(1) = 1
  220. IRET=MCHPOI
  221. MTYPOI=MOT
  222. MOCHDE=MCHPO1.MOCHDE
  223. IFOPOI=ifos
  224. C
  225. DO 250 IA=1,NSOUP1
  226. MSOUP1=MCHPO1.IPCHP(IA)
  227. MSOUP2=MCHPO2.IPCHP(INDEX(IA))
  228. SEGACT MSOUP1,MSOUP2
  229. C
  230. C comparaison des noms des composantes
  231. C
  232. SEGINI MTR1,MTR4
  233. NC1=MSOUP1.NOCOMP(/2)
  234. NC2=MSOUP2.NOCOMP(/2)
  235. DO 130 IB=1,NC1
  236. IPCOM(**)=MSOUP1.NOCOMP(IB)
  237. IPHAR(**)=MSOUP1.NOHARM(IB)
  238. 130 CONTINUE
  239. SEGINI MTR2
  240. DO 160 IB=1,NC2
  241. DO 140 IC=1,NC1
  242. IF(MSOUP2.NOCOMP(IB).NE.MSOUP1.NOCOMP(IC)) GOTO 140
  243. IF(MSOUP2.NOHARM(IB).EQ.MSOUP1.NOHARM(IC)) GOTO 150
  244. 140 CONTINUE
  245. C la composante du IB n'est pas commune
  246. IPCOM(**)=MSOUP2.NOCOMP(IB)
  247. IPHAR(**)=MSOUP2.NOHARM(IB)
  248. IICOM(**)=IPCOM(/2)
  249. GO TO 160
  250. 150 CONTINUE
  251. C la composante est commune
  252. IICOM(**)=IC
  253. 160 CONTINUE
  254. C
  255. MPOVA1=MSOUP1.IPOVAL
  256. MPOVA2=MSOUP2.IPOVAL
  257. SEGACT MPOVA1,MPOVA2
  258. N1=MPOVA1.VPOCHA(/1)
  259. N2=MPOVA2.VPOCHA(/1)
  260. NCX1=MPOVA1.VPOCHA(/2)
  261. NCX2=MPOVA2.VPOCHA(/2)
  262. IF(NCX1.NE.NC1) GOTO 170
  263. IF(NCX2.NE.NC2) GOTO 170
  264. IF(N1.NE.N2) GOTO 170
  265. GOTO 180
  266. 170 CONTINUE
  267. SEGSUP MTR1,MTR2,MTR3,MCHPOI,MTR4
  268. C
  269. C pb avec les dimensions des chpoints
  270. C
  271. CALL ERREUR(114)
  272. IRET=0
  273. C on sort de la sous routine
  274. GOTO 666
  275. C
  276. 180 CONTINUE
  277. N=N1
  278. NC=IPCOM(/2)
  279. SEGINI MPOVAL
  280. NNIN = NC
  281. SEGINI MTR5
  282. C
  283. C mise a 0 de vpocha
  284. C
  285. * DO 190 IB=1,N
  286. * DO 190 IC=1,NC
  287. * VPOCHA(IB,IC)=ZERO
  288. * 190 CONTINUE
  289. C
  290. C addition des chpoints
  291. C
  292. C on place les valeurs de MCHPO1
  293. DO 210 IC=1,NC1
  294. DO 200 IB=1,N
  295. VPOCHA(IB,IC) = MPOVA1.VPOCHA(IB,IC)+VPOCHA(IB,IC)
  296. DMOY(IC) = DMOY(IC) + ABS(VPOCHA(IB,IC)/N)
  297. 200 CONTINUE
  298. IF (IIMPI.EQ.123)
  299. & write (IOIMP,*) ' ic dmoy(ic) ',ic,dmoy(ic)
  300. 210 CONTINUE
  301. C
  302. DO 230 IC=1,NC2
  303. IIC=IICOM(IC)
  304. DO 220 IB=1,N
  305. IF (IIC .LE. NC1 ) THEN
  306. C il s'agit d'ne composante commune
  307. XX1 = MPOVA2.VPOCHA(IB,IC)
  308. XX2 = VPOCHA(IB,IIC)
  309. DXX = ABS ( XX2 - XX1)
  310. * SXX = MIN(ABS ( XX1 + XX2 ) / 2.D0,1.D-50)
  311. SXX = DMOY(IIC)
  312. IF (DXX .LE. (1.D-4*SXX) .or.noer.eq.1) THEN
  313. VPOCHA(IB,IIC)= ( XX1 + XX2 ) / 2.D0
  314. ELSE
  315. C les valeurs des champ diffus au meme point sont différentes
  316. IF (IIMPI.EQ.123)
  317. & write (IOIMP,*) xx1,xx2,SXX,DXX
  318. CALL ERREUR(651)
  319. SEGSUP MTR1,MTR2,MTR3,MCHPOI,MTR4
  320. C on sort
  321. GOTO 666
  322. ENDIF
  323. ELSE
  324. C composantes non communes
  325. VPOCHA(IB,IIC) = MPOVA2.VPOCHA(IB,IC)+VPOCHA(IB,IIC)
  326. ENDIF
  327. 220 CONTINUE
  328. 230 CONTINUE
  329. C
  330. SEGINI MSOUPO
  331. DO 240 IB=1,NC
  332. NOCOMP(IB)=IPCOM(IB)
  333. NOHARM(IB)=IPHAR(IB)
  334. 240 CONTINUE
  335. SEGSUP MTR1,MTR2,MTR4
  336. IPOVAL=MPOVAL
  337. IPT2=MSOUP1.IGEOC
  338. **** SEGINI,IPT1=IPT2
  339. IPT1 = IPT2
  340. IGEOC=IPT1
  341. IPCHP(IA)=MSOUPO
  342. SEGSUP MTR5
  343. 250 CONTINUE
  344. C
  345. SEGSUP MTR3
  346. C on sort
  347. GOTO 666
  348. C
  349. C *** cas ou les supports geometriques ne sont pas identiques
  350. C a une permutation pres
  351. C
  352. 300 CONTINUE
  353. C
  354. C **** a-t-on affaires a des champoints vides?
  355. C
  356. MCHPOI=IP1
  357. c* SEGACT MCHPOI
  358. NS1=IPCHP(/1)
  359. MCHPO2=IP2
  360. c* SEGACT MCHPO2
  361. NS2=MCHPO2.IPCHP(/1)
  362. IF(NS1*NS2.NE.0) GO TO 3001
  363. IF(NS1+NS2.NE.0) THEN
  364. C un seul des chpoints est vide
  365. IF(NS1.EQ.0) IP1=IP2
  366. CALL ECRCHA('GEOM')
  367. CALL ECROBJ('CHPOINT ',IP1)
  368. CALL COPIER
  369. CALL LIROBJ('CHPOINT',IRET,1,IRETOU)
  370. ELSE
  371. C les deux chpoints sont vides
  372. NSOUPO=0
  373. NAT=1
  374. SEGINI MCHPOI
  375. IFOPOI = ifos
  376. IRET = MCHPOI
  377. ENDIF
  378. RETURN
  379. C
  380. 3001 CONTINUE
  381. SEGINI MTRA,MTR1,MTR4
  382. C
  383. C mise a zero de nopoin
  384. C
  385. * DO 305 IA=1,nbpts
  386. * NOPOIN(IA)=0
  387. * 305 CONTINUE
  388. C
  389. MCHPOI=IP1
  390. c* SEGACT MCHPOI
  391. MSOUPO=IPCHP(1)
  392. SEGACT MSOUPO
  393. IPCOM(**)=NOCOMP(1)
  394. IPHAR(**)=NOHARM(1)
  395. NC=1
  396. IK=0
  397. C
  398. C creation de nopoin et de ipcom
  399. C
  400. DO 360 ICH=1,2
  401. MCHPOI=IPO(ICH)
  402. c* SEGACT MCHPOI
  403. NSOUPO=IPCHP(/1)
  404. C
  405. C boucle sur les sous references d 1 chpoint
  406. C
  407. DO 350 IA=1,NSOUPO
  408. MSOUPO=IPCHP(IA)
  409. SEGACT MSOUPO
  410. MELEME=IGEOC
  411. SEGACT MELEME
  412. NBNN =NUM(/1)
  413. NBELEM=NUM(/2)
  414. DO 310 IB=1,NBELEM
  415. K=NUM(1,IB)
  416. IF(NOPOIN(K).NE.0) GO TO 310
  417. IK=IK+1
  418. NOPOIN(K)=IK
  419. 310 CONTINUE
  420. NCBBB=NOCOMP(/2)
  421. DO 330 IB=1,NCBBB
  422. NC=IPCOM(/2)
  423. DO 320 IC=1,NC
  424. IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320
  425. IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 330
  426. 320 CONTINUE
  427. IPCOM(**)=NOCOMP(IB)
  428. IPHAR(**)=NOHARM(IB)
  429. NC=NC+1
  430. 330 CONTINUE
  431. 350 CONTINUE
  432. 360 CONTINUE
  433. C
  434. NNIN=NC
  435. NNNOE=IK
  436. SEGINI MTRAV
  437. C
  438. C initialisation a zero des tableaux
  439. C
  440. SEGINI MTR5
  441. C
  442. * DO 370 IB=1,NNNOE
  443. * DO 370 IA=1,NNIN
  444. * BB(IA,IB)=ZERO
  445. * IBIN(IA,IB)=0
  446. * IMOY(IA,IB) = 0
  447. * 370 CONTINUE
  448. C
  449. C creation de inco
  450. C
  451. DO 380 IA=1,NNIN
  452. INCO(IA)=IPCOM(IA)
  453. NHAR(IA)=IPHAR(IA)
  454. 380 CONTINUE
  455. C
  456. C creation de bb,ibin,igeo
  457. C
  458. DO 450 ICH=1,2
  459. MCHPOI=IPO(ICH)
  460. c* SEGACT MCHPOI
  461. NSOUPO=IPCHP(/1)
  462. DO 430 IA=1,NSOUPO
  463. MSOUPO=IPCHP(IA)
  464. SEGACT MSOUPO
  465. MELEME=IGEOC
  466. SEGACT MELEME
  467. MPOVAL=IPOVAL
  468. SEGACT MPOVAL
  469. NBELEM=NUM(/2)
  470. N=VPOCHA(/1)
  471. NC=VPOCHA(/2)
  472. NC1=NOCOMP(/2)
  473. C
  474. DO 420 IB=1,NC1
  475. DO 390 IC=1,NNIN
  476. IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390
  477. IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400
  478. 390 CONTINUE
  479. 400 CONTINUE
  480. DO 411 ID=1,NBELEM
  481. DMOY(IB)=DMOY(IB)+ABS(VPOCHA(ID,IB)/NBELEM)
  482. 411 CONTINUE
  483. DO 410 ID=1,NBELEM
  484. KI=NOPOIN(NUM(1,ID))
  485. IGEO(KI)=NUM(1,ID)
  486. IF ( IBIN(IC,KI) .EQ. 1) THEN
  487. C la valeur au point est defini dans les deux champs
  488. XX1 = BB(IC,KI)
  489. XX2 = VPOCHA(ID,IB)
  490. DXX = ABS ( XX2 - XX1 )
  491. SXX = DMOY(IB)
  492. IF ( DXX .LE. (1.D-4*SXX).or.noer.eq.1) THEN
  493. BB(IC,KI) = ( XX1 + XX2 ) / 2.D0
  494. ELSE
  495. C les valeurs des champs au meme point sont différentes
  496. IF (IIMPI.EQ.123)
  497. & write (IOIMP,*) xx1,xx2,sxx,DXX
  498. CALL ERREUR (651)
  499. SEGSUP MTRAV,MTRA,MTR1,MTR4,MTR5
  500. GOTO 666
  501. ENDIF
  502. ELSE
  503. BB(IC,KI)=BB(IC,KI)+VPOCHA(ID,IB)
  504. * DMOY(IC) = DMOY(IC) +ABS(BB(IC,KI)/NNNOE)
  505. ENDIF
  506. IBIN(IC,KI)=1
  507. 410 CONTINUE
  508. 420 CONTINUE
  509. 430 CONTINUE
  510. 450 CONTINUE
  511. ITRAV=MTRAV
  512. C
  513. C reconstuction de la partition
  514. C
  515. CALL CRECHP(ITRAV,ICHPOI)
  516. C
  517. SEGSUP MTRAV,MTRA,MTR1,MTR4,MTR5
  518. IRET=ICHPOI
  519. MCHPOI=ICHPOI
  520. c* MCHPO1 = IP1
  521. c* MCHPO2 = IP2
  522. c* NAT1 = MCHPO1.JATTRI(/1)
  523. c* NAT2 = MCHPO2.JATTRI(/1)
  524. NAT=MAX(NAT1,NAT2,1)
  525. NSOUPO = IPCHP(/1)
  526. SEGADJ MCHPOI
  527. IRET=MCHPOI
  528. MTYPOI=MOT
  529. IFOPOI = ifos
  530. JATTRI(1) = 1
  531. C
  532. 666 CONTINUE
  533. c* RETURN
  534. END
  535.  
  536.  
  537.  

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