Télécharger combil.eso

Retour à la liste

Numérotation des lignes :

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

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