Télécharger combil.eso

Retour à la liste

Numérotation des lignes :

  1. C COMBIL SOURCE BP208322 17/12/18 21:15:00 9667
  2. C COMBIL SOURCE BP208322 15/06/26 21:15:07 8562
  3.  
  4. SUBROUTINE COMBIL(ITACH,ITAFL,NCH,IRETT)
  5.  
  6. C----------------------------------------------------------------------
  7. C CE SUBROUTINE EFFECTUE LA COMBINAISON LINEAIRE DES NCH CHPOINT
  8. C CONTENUS DANS ITACH, AVEC LES NCH FLOTTANTS CONTENUS DANS ITAFL
  9. C LE RESULTAT EST UN CHPOINT,MIS DANS IRETT
  10. C ATTENTION : TAFL EN DOUBLE PRECISION
  11. c BP, 2015-06-26 : segments actifs en E/S
  12. c BP, 2017-12-14 : changement de methode inspire de funobj
  13. C----------------------------------------------------------------------
  14.  
  15. IMPLICIT INTEGER(I-N)
  16. IMPLICIT REAL*8 (A-H,O-Z)
  17.  
  18. -INC CCOPTIO
  19. -INC SMCOORD
  20. -INC SMCHPOI
  21. -INC TMTRAV
  22. -INC SMELEME
  23.  
  24. c SEGMENTS D'ENTREE :
  25. SEGMENT ITACH(0)
  26. SEGMENT/ITAFL/(TAFL(0)*D)
  27.  
  28. C ITRAV : SEGMENT DE TRAVAIL POUR CRECHP
  29. SEGMENT ITRAV
  30. CHARACTER*4 INC (NN)
  31. INTEGER IHAR(NN)
  32. ENDSEGMENT
  33.  
  34. C ICPR(#global) = #local
  35. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  36.  
  37. C IZON1(#local) = indice de la zone a laquelle appartient ce noeud
  38. SEGMENT IZON1(NZON1)
  39.  
  40. c IIPT1(indice de zone) = maillage support definissant cette zone
  41. SEGMENT IIPT1(NIPT1)
  42.  
  43. c IELEM(#local)=#element de IPT1
  44. SEGMENT IELEM(NZON1)
  45.  
  46. SEGMENT MICOM(NCOM)
  47.  
  48. INTEGER OOOVAL
  49. CHARACTER*8 CHA8,CHA8a,CHA8b
  50. REAL*8 VAL
  51. C
  52. IRETT=0
  53.  
  54. IF(NCH.GT.1) GOTO 2
  55. C----------------------------------------------------------------------
  56. C METHODE POUR NCH=1
  57. C----------------------------------------------------------------------
  58. ICHPO=ITACH(1)
  59. VAL=TAFL(1)
  60. CALL MUCHPO(ICHPO,VAL,IRETT,1)
  61. RETURN
  62.  
  63. 2 CONTINUE
  64. IF(NCH.GT.2) GOTO 3
  65. C----------------------------------------------------------------------
  66. C METHODE POUR NCH=2
  67. C----------------------------------------------------------------------
  68. ICHPO1=ITACH(1)
  69. ICHPO2=ITACH(2)
  70. VAL1=TAFL(1)
  71. VAL2=TAFL(2)
  72. CALL ADCHPO(ICHPO1,ICHPO2,IRETT,VAL1,VAL2)
  73. RETURN
  74.  
  75. 3 CONTINUE
  76. C----------------------------------------------------------------------
  77. C METHODEs POUR NCH>2 :
  78. c addition de CHPOINT en une seule fois (Pas de CHPOINT temporaires)
  79. c - methode RAPIDE : evite la partition de la geometrie
  80. c (inspiree de adchpo.eso)
  81. c - methode GENERALE : pas d'hypothese sur les supports
  82. c (inspiree de funobj.eso)
  83. C----------------------------------------------------------------------
  84.  
  85. c INITIALISATIONS
  86. NN = 0
  87. NNIN = 0
  88. NNNOE = 0
  89. NAT = 1
  90. NATi = -1
  91. NATf = -1
  92. CHA8 = ' '
  93. CHA8a = ' '
  94. CHA8b = ' '
  95. SEGACT,MCOORD
  96. SEGINI,ICPR
  97. NLOC = 0
  98. NIPT1 = 0
  99. NCOM = 0
  100.  
  101. C---- OUVERTURE DE TOUS LES MCHPOI ----
  102. DO 400 III = 1,NCH
  103. MCHPOI = ITACH(III)
  104. SEGACT,MCHPOI
  105. NSOUPO = MCHPOI.IPCHP(/1)
  106. NAT = MAX(NAT,MCHPOI.JATTRI(/1))
  107. NATi = MCHPOI.JATTRI(1)
  108. CHA8 = MCHPOI.MTYPOI
  109. IF(III .EQ. 1) THEN
  110. NATf = NATi
  111. CHA8a=CHA8
  112. CHA8b=CHA8
  113. ELSE
  114. IF (NATi .NE. NATf) THEN
  115. NATf=0
  116. ENDIF
  117. IF (CHA8 .NE. CHA8a) THEN
  118. CHA8b='INDETERM'
  119. ENDIF
  120. ENDIF
  121. NIPT1=NIPT1+NSOUPO
  122. DO 401 JJJ = 1,NSOUPO
  123. C Ouverture de tous les MSOUPO
  124. MSOUPO = MCHPOI.IPCHP(JJJ)
  125. SEGACT,MSOUPO
  126. NC=MSOUPO.NOHARM(/1)
  127. NN=NN+NC
  128. NCOM=MAX(NCOM,NC)
  129.  
  130. c +++ on regarde si on peut eviter de partitionner la geometrie +++
  131. c (remplissage de ICPR et IZON)
  132. MELEME=IGEOC
  133. SEGACT,MELEME
  134. DO 402 IEL=1,NUM(/2)
  135. INUM=NUM(1,IEL)
  136. ILOC=ICPR(INUM)
  137. c si noeud jamais vu : on l'ajoute a ICPR
  138. IF(ILOC.EQ.0) THEN
  139. NLOC=NLOC+1
  140. ILOC=NLOC
  141. ICPR(INUM)=ILOC
  142. ENDIF
  143. c IZON(indice chpoint,#local car trop gros sinon)=indice de zone
  144. c IZON(III,ILOC)=JJJ
  145. 402 CONTINUE
  146.  
  147. 401 CONTINUE
  148. 400 CONTINUE
  149.  
  150. c +++ on regarde si on peut eviter de partitionner la geometrie +++
  151. NZON1=NLOC
  152. SEGINI,IZON1,IIPT1
  153. IBMAX=0
  154. DO 410 III = 1,NCH
  155. MCHPOI = ITACH(III)
  156. NSOUPO = MCHPOI.IPCHP(/1)
  157. DO 411 JJJ = 1,NSOUPO
  158. MSOUPO = MCHPOI.IPCHP(JJJ)
  159. MELEME = IGEOC
  160. INUM11=NUM(1,1)
  161. ILOC11=ICPR(INUM11)
  162. c quelle zone du chpoint final est associee a ce noeud ?
  163. IB = IZON1(ILOC11)
  164. IF(IB.EQ.0) THEN
  165. c on verifie bien qu'on a jamais vu aucun noeud de ce maillage
  166. IBMAX=IBMAX+1
  167. DO 412 IEL=1,NUM(/2)
  168. INUM=NUM(1,IEL)
  169. ILOC=ICPR(INUM)
  170. IF(IZON1(ILOC).NE.IB) GOTO 419
  171. IZON1(ILOC)=IBMAX
  172. 412 CONTINUE
  173. c ici, tous les noeuds de MELEME appartiennent a la zone IB=0
  174. c il faut ajouter MELEME dans IIPT1 (+ noeuds dans IZON1)
  175. IIPT1(IBMAX)=MELEME
  176. ELSE
  177. c on verifie bien qu'il s'agit bien du meme maillage
  178. IPT1=IIPT1(IB)
  179. IF(MELEME.EQ.IPT1) GOTO 411
  180. IF(NUM(/2).NE.IPT1.NUM(/1)) GOTO 419
  181. c il faut verifier que tous les noeuds sont dans la zone IB
  182. DO 413 IEL=1,NUM(/2)
  183. INUM=NUM(1,IEL)
  184. ILOC=ICPR(INUM)
  185. IF(IZON1(ILOC).NE.IB) GOTO 419
  186. 413 CONTINUE
  187. c ici, tous les noeuds de MELEME appartiennent a la zone IB
  188. ENDIF
  189. 411 CONTINUE
  190. 410 CONTINUE
  191.  
  192.  
  193. C----------------------------------------------------------------------
  194. c methode RAPIDE (evitant de partitionner la geometrie)
  195. C----------------------------------------------------------------------
  196. c write(*,*) 'combil: methode rapide',NLOC,NCOM
  197. NZON1=NLOC
  198. SEGINI,IELEM,MICOM
  199.  
  200. c Creation du chpoint de sortie : MCHPO1
  201. NSOUPO=IBMAX
  202. SEGINI,MCHPO1
  203. c MCHPOI=ITACH(1)
  204. c MCHPO1.MTYPOI=MTYPOI
  205. c MCHPO1.MOCHDE='COMBINAISON LINEAIRE'
  206. c MCHPO1.JATTRI(1)=JATTRI(1)
  207. c MCHPO1.IFOPOI=IFOPOI
  208.  
  209. c boucle sur les chpoints en entree
  210. DO 700 III = 1,NCH
  211. MCHPOI = ITACH(III)
  212. VAL = TAFL(III)
  213. NSOUPO = MCHPOI.IPCHP(/1)
  214.  
  215. DO 701 JJJ = 1,NSOUPO
  216. c ajout de la contribution de la JJ eme zone du III eme chpoint
  217. MSOUPO = IPCHP(JJJ)
  218. NC0 = NOCOMP(/2)
  219. MELEME = IGEOC
  220. MPOVAL = IPOVAL
  221. SEGACT,MPOVAL
  222. N0 = VPOCHA(/1)
  223. INUM11 = NUM(1,1)
  224. ILOC11 = ICPR(INUM11)
  225. c ... a la zone IB du chpoint de sortie
  226. IB = IZON1(ILOC11)
  227. MSOUP1 = MCHPO1.IPCHP(IB)
  228. IPT1 = IIPT1(IB)
  229.  
  230. c +si MSOUP1 n'existe pas il faut creer MSOUP1 et MPOVA1
  231. IF(MSOUP1.LE.0) THEN
  232. NC=NC0
  233. N=N0
  234. SEGINI,MSOUP1=MSOUPO
  235. MCHPO1.IPCHP(IB)=MSOUP1
  236. MSOUP1.IGEOC=IPT1
  237. c pas de pb de composante car on a duplique
  238. SEGINI,MPOVA1
  239. MSOUP1.IPOVAL=MPOVA1
  240. c -cas maillage identique : pas de pb
  241. IF(MELEME.EQ.IPT1) THEN
  242. DO 710 K1=1,N0
  243. DO 710 K2=1,NC0
  244. MPOVA1.VPOCHA(K1,K2)=VAL*VPOCHA(K1,K2)
  245. 710 CONTINUE
  246. c -cas maillages differents :
  247. c on remplit IELEM(#local)=#element de IPT1
  248. ELSE
  249. c rem : on ne remet pas a 0 IELEM car on va parcourir
  250. c exactement les noeuds remplis
  251. DO IEL=1,IPT1.NUM(/2)
  252. ILOC=ICPR(IPT1.NUM(1,IEL))
  253. IELEM(ILOC)=IEL
  254. ENDDO
  255. DO 712 K1=1,N0
  256. ILOC=ICPR(NUM(1,K1))
  257. IEL=IELEM(ILOC)
  258. DO 713 K2=1,NC0
  259. MPOVA1.VPOCHA(K1,K2)=VAL*VPOCHA(IEL,K2)
  260. 713 CONTINUE
  261. 712 CONTINUE
  262. ENDIF
  263.  
  264. c +MSOUP1 deja existant
  265. ELSE
  266. c -recensement des composantes
  267. NC1=MSOUP1.NOCOMP(/2)
  268. NC=NC1
  269. MPOVA1=MSOUP1.IPOVAL
  270. N1=MPOVA1.VPOCHA(/1)
  271. N=N1
  272. DO 730 IC=1,NC0
  273. DO 731 IC1=1,NC1
  274. IF(NOCOMP(IC).NE.MSOUP1.NOCOMP(IC1)) GOTO 731
  275. IF(NOHARM(IC).EQ.MSOUP1.NOHARM(IC1)) GOTO 732
  276. 731 CONTINUE
  277. c on n'a pas trouve la composante IC : on agrandit
  278. NC=NC+1
  279. SEGADJ,MSOUP1
  280. IC1=NC
  281. MSOUP1.NOCOMP(IC1)=NOCOMP(IC)
  282. MSOUP1.NOHARM(IC1)=NOHARM(IC)
  283. 732 CONTINUE
  284. c on a trouve la composante IC en IC1
  285. MICOM(IC)=IC1
  286. 730 CONTINUE
  287. IF(NC.GT.NC1) SEGADJ,MPOVA1
  288. c -cas maillage identique : pas de pb
  289. IF(MELEME.EQ.IPT1) THEN
  290. DO 750 K1=1,N0
  291. DO 751 K2=1,NC0
  292. IC1=MICOM(K2)
  293. MPOVA1.VPOCHA(K1,IC1)=(VAL*VPOCHA(K1,K2))
  294. & +MPOVA1.VPOCHA(K1,IC1)
  295. 751 CONTINUE
  296. 750 CONTINUE
  297. c -cas maillages differents :
  298. c on remplit IELEM(#local)=#element de IPT1
  299. ELSE
  300. DO IEL=1,IPT1.NUM(/2)
  301. ILOC=ICPR(IPT1.NUM(1,IEL))
  302. IELEM(ILOC)=IEL
  303. ENDDO
  304. DO 752 K1=1,N0
  305. ILOC=ICPR(NUM(1,K1))
  306. IEL=IELEM(ILOC)
  307. DO 753 K2=1,NC0
  308. IC1=MICOM(K2)
  309. MPOVA1.VPOCHA(K1,IC1)=(VAL*VPOCHA(IEL,K2))
  310. & +MPOVA1.VPOCHA(K1,IC1)
  311. 753 CONTINUE
  312. 752 CONTINUE
  313. ENDIF
  314.  
  315. ENDIF
  316.  
  317. 701 CONTINUE
  318.  
  319. 700 CONTINUE
  320.  
  321. c Desactivation/suppression
  322. SEGSUP,ICPR,IZON1,IIPT1,IELEM
  323. IRETT=MCHPO1
  324. GOTO 900
  325.  
  326.  
  327.  
  328. 419 CONTINUE
  329. SEGSUP,IZON1
  330. C----------------------------------------------------------------------
  331. c methode GENERALE (pas d'hypothese sur les supports)
  332. C----------------------------------------------------------------------
  333. c write(*,*) 'combil: methode generale'
  334.  
  335. C---- DECOMPTE ET STOCKAGE DES COMPOSANTES DIFFERENTES ----
  336. SEGINI,ITRAV,ICPR
  337. DO 420 III = 1,NCH
  338. MCHPOI = ITACH(III)
  339. DO 430 JJJ = 1,MCHPOI.IPCHP(/1)
  340. MSOUPO = MCHPOI.IPCHP(JJJ)
  341. DO 431 KKK = 1,MSOUPO.NOHARM(/1)
  342. DO 432 LLL = 1,NNIN
  343. IF(MSOUPO.NOCOMP(KKK) .NE. ITRAV.INC (LLL)) GOTO 432
  344. IF(MSOUPO.NOHARM(KKK) .EQ. ITRAV.IHAR(LLL)) GOTO 431
  345. 432 CONTINUE
  346. c nouveau ddl : on l'ajoute a la liste ITRAV
  347. NNIN = NNIN + 1
  348. ITRAV.INC (NNIN)=MSOUPO.NOCOMP(KKK)
  349. ITRAV.IHAR(NNIN)=MSOUPO.NOHARM(KKK)
  350. 431 CONTINUE
  351. IPT1 =MSOUPO.IGEOC
  352. MPOVAL=MSOUPO.IPOVAL
  353. c SEGACT,IPT1,MPOVAL
  354. SEGACT,MPOVAL
  355. DO 433 MMM=1,IPT1.NUM(/2)
  356. INOEUD=IPT1.NUM(1,MMM)
  357. c nouveau noeud : on l'ajoute a la liste ICPR
  358. IF(ICPR(INOEUD) .EQ. 0) THEN
  359. NNNOE = NNNOE + 1
  360. ICPR(INOEUD)= NNNOE
  361. ENDIF
  362. 433 CONTINUE
  363. 430 CONTINUE
  364. 420 CONTINUE
  365.  
  366. C---- CREATION DE MTRAV ET REMPLISSAGE ----
  367. SEGINI,MTRAV
  368. DO 450 III = 1,NCH
  369. MCHPOI = ITACH(III)
  370. VAL = TAFL(III)
  371. DO 460 JJJ = 1,MCHPOI.IPCHP(/1)
  372. MSOUPO=MCHPOI.IPCHP(JJJ)
  373. IPT1 =MSOUPO.IGEOC
  374. MPOVAL=MSOUPO.IPOVAL
  375. C Recherche de la composante correspondante
  376. DO 461 KKK=1,MSOUPO.NOCOMP(/2)
  377. DO 462 LLL=1,NNIN
  378. IF(MSOUPO.NOCOMP(KKK) .NE. ITRAV.INC (LLL)) GOTO 462
  379. IF(MSOUPO.NOHARM(KKK) .EQ. ITRAV.IHAR(LLL)) GOTO 463
  380. 462 CONTINUE
  381. CALL ERREUR(5)
  382. 463 CONTINUE
  383. C on procede a la combinaison lineaire des valeurs
  384. c en 1 pt d'une meme composante
  385. DO 465 MMM=1,IPT1.NUM(/2)
  386. INOEUD =ICPR(IPT1.NUM(1,MMM))
  387. IGEO(INOEUD)= IPT1.NUM(1,MMM)
  388. IBIN(LLL,INOEUD)= 1
  389. BB (LLL,INOEUD)= BB(LLL,INOEUD)
  390. & +(VAL*MPOVAL.VPOCHA(MMM,KKK))
  391. 465 CONTINUE
  392. 461 CONTINUE
  393. c SEGDES,IPT1,MPOVAL,MSOUPO
  394. SEGDES,MPOVAL
  395. 460 CONTINUE
  396. c SEGDES,MCHPOI
  397. C Remplissage des NOMS de composante et NUMEROS d'harmoniques
  398. DO 451 JJJ = 1,NNIN
  399. INCO(JJJ)=ITRAV.INC (JJJ)
  400. NHAR(JJJ)=ITRAV.IHAR(JJJ)
  401. 451 CONTINUE
  402. 450 CONTINUE
  403. SEGSUP,ITRAV,ICPR
  404.  
  405. C---- FERMETURE DE TOUS LES MCHPOI ----
  406. DO 500 III = 1,NCH
  407. MCHPOI = ITACH(III)
  408. DO 510 JJJ = 1,MCHPOI.IPCHP(/1)
  409. MSOUPO=MCHPOI.IPCHP(JJJ)
  410. IPT1 =MSOUPO.IGEOC
  411. SEGDES,IPT1,MSOUPO
  412. 510 CONTINUE
  413. SEGDES,MCHPOI
  414. 500 CONTINUE
  415.  
  416.  
  417. C---- CREATION DU CHPOINT FINAL A PARTIR DU MTRAV ----
  418. CALL CRECHP (MTRAV,ID1)
  419. SEGSUP,MTRAV
  420. IRETT=ID1
  421.  
  422.  
  423. 900 CONTINUE
  424. C---- DERNIERS AJUSTEMENTS DU CHPOINT FINAL ----
  425. MCHPOI=IRETT
  426. C Dans crechp "NAT" vaut 1, on AJUSTE le SEGMENT si besoin
  427. SEGACT,MCHPOI*MOD
  428. IF (NAT .GT. MCHPOI.JATTRI(/1))SEGADJ,MCHPOI
  429. C Le chapeau du CHPOINT est complete d'apres le premier de la liste
  430. MCHPO4 = ITACH(1)
  431. SEGACT,MCHPO4
  432. MCHPOI.MTYPOI=CHA8b
  433. MCHPOI.MOCHDE='COMBINAISON LINEAIRE'
  434. DO IATT=1,NAT
  435. MCHPOI.JATTRI(IATT)=NATf
  436. ENDDO
  437. MCHPOI.IFOPOI=MCHPO4.IFOPOI
  438. SEGDES,MCHPOI,MCHPO4
  439.  
  440. RETURN
  441.  
  442. END
  443.  
  444.  
  445.  
  446.  

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