Télécharger conne1.eso

Retour à la liste

Numérotation des lignes :

conne1
  1. C CONNE1 SOURCE KICH 22/11/21 21:15:02 11505
  2. SUBROUTINE CONNE1(IPMODL,XLONG,IXLONG,CONSTI,ICLE,JPT1,JPT2,JPT3,
  3. > IPCHCO,IRET)
  4. C_______________________________________________________________________
  5. C
  6. C CALCUL DES CONNECTIVITES APPELE PAR CONNEC
  7. C
  8. C Entrees:
  9. C ________
  10. C
  11. C IPMODL Pointeur sur un objet MMODEL
  12. C XLONG Longeur caracteristique
  13. C IXLONG Champ de longeur caracteristique
  14. C CONSTI nom du constituant
  15. C ICLE mode de modification du maillage pour le calcul
  16. C (1=NORM, 3=POIN, 4=DROI, 5=PLAN, 2=TRAN)
  17. C JPT1|
  18. C JPT2| pointeurs eventuels sur des objets de type point
  19. C JPT3|
  20. C
  21. C
  22. C Sorties:
  23. C ________
  24. C
  25. C IPCHCO Pointeur sur un MCHAML de Connectivite
  26. C de composantes obligatoires ...
  27. C
  28. C 'NLAR': Non local Longueur cARacteristique
  29. C 'PMOD': Pointeur sur un MMODEL contenant
  30. C l'ensemble des IMODEL accessibles
  31. C pour la sous zone
  32. C 'NPNI': Non local Pointeur Numero Imodel de nmod
  33. C 'NPLI': Non local Pointeur LIstenti
  34. C
  35. C ... et eventuellement
  36. C
  37. C 'POT1': Point ou vecteur de construction de symetrie
  38. C (POIN, DROI, PLAN, TRAN)
  39. C 'POT2': Point de construction de symetrie (DROI)
  40. C 'DISP': Distance pour calcul de symetrie PLAN (PLAN)
  41. C
  42. C IRET 1 ou 0 suivant succes ou pas
  43. C
  44. C Appele par: CONNEC
  45. C -----------
  46. C
  47. C Appel a:
  48. C --------
  49. C
  50. C LOADPO : lecture d'un point (pointeur --> x(3))
  51. C NORPLA : calcul de l'eq. canonique d'un plan passant par 3 pts
  52. C ADJUPO : ajout d'un point dans la pile des points (x(3) --> pointeur)
  53. C NORDRO : calcul du vect. dir. norme de la droite passant par 2 pts
  54. C DISYPT : distance a un point
  55. C DISYDR : distance a une droite
  56. C DISYPL : distance a un plan
  57. C TRTRVE : point translate
  58. C TRSYPT : point symetrique par rapport a un point
  59. C TRSYDR : point symetrique par rapport a une droite
  60. C TRSYPL : point symetrique par rapport a un plan
  61. C ELQUOI, DOXE, DTSHAM
  62. C
  63. C AUTEUR P.PEGON 22/10/92 d'apres C. LA BORDERIE d'apres P.PEGON
  64. C_______________________________________________________________________
  65. C
  66. IMPLICIT INTEGER(I-N)
  67. IMPLICIT REAL*8(A-H,O-Z)
  68. CHARACTER*16 CONSTI
  69. DIMENSION PT3(3)
  70.  
  71. C
  72. -INC SMMODEL
  73. -INC CCREEL
  74. -INC PPARAM
  75. -INC CCOPTIO
  76. -INC SMELEME
  77. -INC SMCOORD
  78. -INC SMCHAML
  79. -INC SMLENTI
  80.  
  81. -INC CCASSIS
  82.  
  83. PARAMETER(MASDIM=64)
  84. common/CCONNE/iwrk3,ipmodl1,xmultl,icle1,ihgsel
  85. common/CCONNE/jconl,ihg1,ihg2,ihg,nbthr,ixlong1
  86. COMMON/CHSELE/imfopa,ishg,ihug,imcord,ihgt
  87. common/CCONN1/d,pt1(3),pt2(3)
  88. common/CCONN1/xmn(masdim),ymn(masdim),zmn(masdim)
  89. common/CCONN1/xmx(masdim),ymx(masdim),zmx(masdim)
  90. common/CCONN1/hmxt(masdim),xlg2m(masdim)
  91. external crbary
  92. external hselei
  93. logical zthr
  94. SEGMENT,WRK1
  95. REAL*8 XE(3,nbno1)
  96. C coord des noeuds
  97. ENDSEGMENT
  98.  
  99. SEGMENT,WRK2
  100. REAL*8 XEJ(3,nbno1)
  101. ENDSEGMENT
  102.  
  103. SEGMENT,WRK3
  104. INTEGER IWRK1(NSOUS,nbthr), IWRK2(NSOUS,nbthr)
  105. + ,imptv(nsous)
  106. C iwrk1 pointe vers les wrk1 et iwrk2 pointe sur les wrk2
  107. ENDSEGMENT
  108.  
  109. pointeur IPMAIL.MELEME
  110. pointeur MLNIMO.MLENTI
  111. pointeur MLNUEL.MLENTI
  112. pointeur MCORD2.MCOORD
  113.  
  114. CHARACTER*(NCONCH) CONM
  115. PARAMETER (NINF=3)
  116. INTEGER INFOS(NINF)
  117.  
  118. SEGMENT NOTYPE
  119. CHARACTER*16 TYPE(NBTYPE)
  120. ENDSEGMENT
  121.  
  122. SEGMENT MPTVAL
  123. INTEGER IPOS(NS), NSOF(NS)
  124. INTEGER IVAL(NCOSOU)
  125. CHARACTER*16 TYVAL(NCOSOU)
  126. ENDSEGMENT
  127.  
  128. SEGMENT INFO
  129. INTEGER INFELL(JG)
  130. ENDSEGMENT
  131. C hg1 contient les coordonnees des barycentres de la zone de travail
  132. C hg2 contient les coordonnees des barycentres de la deuxieme zone
  133. SEGMENT HG1
  134. REAL*8 HCOOR(3*nbpb)
  135. ENDSEGMENT
  136. pointeur hg2.hg1
  137. C HG contient les correspondances entre numérotation locale et numerotation castem
  138. C ainsi que des donnees permettant d'ecrire le resultat
  139. SEGMENT HG
  140. INTEGER IELH(nbpb,2)
  141. C IELH(i,1)=numero de l'element dans la sous zone
  142. C IELH(i,2)=numero de la sous zone
  143. C Tableau qui contient le max d(noeuds, barycentre)
  144. REAL*8 HMax(nbpb)
  145. C si ixlong different de zero contient le max de ixlong dans l'element
  146. REAL*8 XLL(nbpb)
  147. C Tableau qui contient nombre d'ele en connex par sous zone
  148. INTEGER INOA(nbpb,NSOUS+1)
  149. ENDSEGMENT
  150. C hgt contient les tableaux utile pour le tri
  151. SEGMENT HGT
  152. C integer ka(nels),kb(nels)
  153. C Tableau contenant proj ortho sur la droite apres tri
  154. REAL*8 Xp(nels)
  155. C Tableau auxiliaire pour triflot
  156. REAL*8 Xw(nels)
  157. C Tableau auxiliaire pour triflot
  158. INTEGER Ke(nels)
  159. C Tableau donne la correspondance entre le tableau trie et la numerotation de la zone 2
  160. INTEGER ICO(nels)
  161. ENDSEGMENT
  162.  
  163.  
  164. SEGMENT mfopa
  165. C Premier element dans un segment de la droite
  166. INTEGER ind(indt)
  167. ENDSEGMENT
  168. C lhug la liste des elements en relation - on s'y retrouve grace a inoa
  169. SEGMENT iVECTI
  170. INTEGER Lhug(JG)
  171. ENDSEGMENT
  172. pointeur ivect1.ivecti
  173.  
  174. segment mlhug
  175. integer ilhug(nbthr)
  176. integer nhug(nbthr)
  177. endsegment
  178. C VECTEUR corresp entre numero des elements conserves (cas symetrie) et numerotation locale
  179. SEGMENT SHG
  180. INTEGER NSYM(NELS)
  181. ENDSEGMENT
  182.  
  183. C permet de ne pas recalculer le symetrique d'un noeud
  184. SEGMENT NOETR
  185. INTEGER NDEJVU(NBPTS)
  186. ENDSEGMENT
  187. C permet de savoir s'il faut creer un segment resultat (1 oui 0 non)
  188. SEGMENT CONL
  189. INTEGER ICONL(NBPB)
  190. ENDSEGMENT
  191. segment kkzt
  192. integer kzt(nbpb)
  193. endsegment
  194.  
  195. segment hgsele
  196. real*8 xmult,ymult,zmult
  197. real*8 hmaxt,xlong2,tmax,tmin,xlong2m
  198. integer nels,nbpb,ipass
  199. integer nbzt,indt,khug
  200. endsegment
  201.  
  202.  
  203. integer ittime(4)
  204. data xmultl/1.5D0/
  205. c
  206. C i232 = 2**32
  207.  
  208. ixlong1 = ixlong
  209. icle1 = icle
  210. C LECTURE DES POINTS
  211. CALL LOADPO(JPT1,PT1)
  212. CALL LOADPO(JPT2,PT2)
  213. CALL LOADPO(JPT3,PT3)
  214.  
  215. C CALCUL DE LA NORMALE NORMEE ET DE LA DISTANCE POUR KE CAS DU PLAN
  216. C ET AJOUT DU POINT A LA PILE
  217.  
  218. segini hgsele
  219. ihgsel = hgsele
  220. khug = 0
  221. C call timespv(ittime,othrd)
  222. C ide = ittime(1) + ittime(2)
  223. IF (ICLE.EQ.5) then
  224. CALL NORPLA(PT1,PT2,PT3,pt1,D)
  225. CALL ADJUPO(PT1,JPT1)
  226. ENDIF
  227. C CALCUL DU VECTEURE DIRECTEUR NORME DANS
  228. C DANS LE CAS DE LA DROITE ET AJOUT DU POINT A LA PILE
  229. C
  230. IF (ICLE.EQ.4) THEN
  231. CALL NORDRO(PT1,PT2,PT2)
  232. CALL ADJUPO(PT2,JPT2)
  233. ENDIF
  234. C
  235. C
  236.  
  237. iret=1
  238. C
  239. C
  240. C____________________________________________________________________
  241. C
  242. C PREPARATIONS DE LA LONGUEUR CARACTERISTIQUE
  243. C____________________________________________________________________
  244. C
  245. IF(IXLONG.NE.0)THEN
  246. C
  247. INFOS(1)=0
  248. INFOS(2)=0
  249. INFOS(3)=NIFOUR
  250. C
  251. NBROBL=1
  252. NBRFAC=0
  253. SEGINI NOMID
  254. NOMLAR=NOMID
  255. LESOBL(1)='LCAR'
  256. NBTYPE=1
  257. SEGINI NOTYPE
  258. MOTYPE=NOTYPE
  259. TYPE(1)='REAL*8'
  260. ELSE
  261. XLONG2 = XMULTl * XLONG
  262. ENDIF
  263. C
  264. C ACTIVATION DU MODELE
  265. C
  266. MMODEL=IPMODL
  267. SEGACT,MMODEL
  268. NSOUS=KMODEL(/1)
  269. C
  270. C ACTIVATION DES ZONES ELEMENTAIRES DU MAILLAGE
  271. C
  272. nbthr = nbthrs
  273. segini wrk3
  274. nbelz=0
  275. DO ISOUS=1,NSOUS
  276. IMODEL=KMODEL(ISOUS)
  277. SEGACT,IMODEL
  278. IPMAIL=IMAMOD
  279. SEGACT,IPMAIL
  280. nbno1=IPMAIL.num(/1)
  281. nbelz=nbelz + IPMAIL.num(/2)
  282. do i = 1, nbthrs
  283. segini wrk1
  284. segini wrk2
  285. wrk3.iwrk1(isous,i)=wrk1
  286. wrk3.iwrk2(isous,i)=wrk2
  287. enddo
  288. if (ixlong.ne.0) then
  289. conm = conmod
  290. mele = ipmail.itypel
  291. if (infmod(/1).lt.7) then
  292. call elquoi(mele,0,5,ipinf,imodel)
  293. if (ierr.ne.0) goto 9999
  294. info = ipinf
  295. minte = infell(11)
  296. segsup info
  297. else
  298. minte = infmod(7)
  299. endif
  300. call komcha(ixlong,ipmail,conm,nomlar,motype,1,infos,3
  301. + ,ivalar)
  302. if (ierr.ne.0) then
  303. nomid = nomlar
  304. notype = motype
  305. segsup ,nomid,notype
  306. goto 9999
  307. endif
  308. mptval = ivalar
  309. melval = ival(1)
  310. segact melval
  311. imptv(isous) = melval
  312. call dtmval(ivalar,2)
  313. endif
  314. ENDDO
  315.  
  316. nbpb=nbelz
  317.  
  318. segini kkzt
  319. SEGINI HG
  320. ihg = hg
  321. segini hg1
  322. ihg1 = hg1
  323. ihg2 = hg1
  324. xmin=xgrand
  325. ymin=xgrand
  326. zmin=xgrand
  327. xmax=-xgrand
  328. ymax=-xgrand
  329. zmax=-xgrand
  330. hmaxt = 0d0
  331. xlong2m = 0d0
  332. C
  333. mcord2=mcoord
  334. imcord = mcord2
  335. hg2=hg1
  336. SEGINI CONL
  337. do ib1=1,nbpb
  338. iconl(ib1)=1
  339. ENDDO
  340. C on regarde si on parallelise
  341. if (LODESL.or.nbthrs.eq.1.or.nbpb.lt.nbthrs) then
  342. zthr = .FALSE.
  343. nbthr = 1
  344. else
  345. zthr = .TRUE.
  346. nbthr = nbthrs
  347. C nbthr = 20
  348. endif
  349. C zthr = .FALSE.
  350. C nbthr = 1
  351. C On fait une boucle pour créer une numerotation
  352. C
  353. ib1 = 0
  354. NELS = NBPB
  355. ishg = 0
  356. if (icle.ne.1) then
  357. SEGINI SHG,hg2
  358. ishg = shg
  359. ihg2 = hg2
  360. endif
  361. do isous = 1, nsous
  362. IMODEL = KMODEL(ISOUS)
  363. IPMAIL = IMAMOD
  364. nbel1 = IPMAIL.num(/2)
  365. nbno1 = IPMAIL.num(/1)
  366. do iel1 = 1, nbel1
  367. IB1 = IB1 + 1
  368. IELH(IB1,1) = iel1
  369. IELH(IB1,2) = ISOUS
  370. enddo
  371. enddo
  372. jconl = conl
  373. inoetr = noetr
  374. iwrk3 = wrk3
  375. C ihg = hg
  376. ipmodl1 = ipmodl
  377.  
  378. C On fait une boucle sur tous les éléments pour créer les centres de gravité et une numérotation
  379. if (zthr) then
  380. call threadii
  381. do ith = 2, nbthr
  382. call threadid(ith,crbary)
  383. enddo
  384. call crbary(1)
  385. do ith = 2, nbthr
  386. call threadif(ith)
  387. enddo
  388. call threadis
  389. else
  390. call crbar1(iwrk3,ipmodl1,1,nbpb,xmultl,icle,d,pt1,pt2
  391. + ,jconl,ihg1,ihg2,xmn,ymn,zmn,xmx,ymx,zmx
  392. + ,hmxt,ihg,1,ixlong,xlong2,xlg2m)
  393. endif
  394. c
  395. do i = 1, nbthr
  396. xmax = max (xmax,xmx(i))
  397. ymax = max (ymax,ymx(i))
  398. zmax = max (zmax,zmx(i))
  399. xmin = min (xmin,xmn(i))
  400. ymin = min (ymin,ymn(i))
  401. zmin = min (zmin,zmn(i))
  402. hmaxt = max (hmaxt,hmxt(i))
  403. xlong2m = max(xlong2m,xlg2m(i))
  404. enddo
  405.  
  406. C
  407. C on fait une boucle pour tasser les tableaux dans le cas icle = 3,4,5
  408. if (icle.eq.2.or.icle.eq.3.or.icle.eq.4.or.icle.eq.5) then
  409. ik1 = 0
  410. ib = 0
  411. do ib = 1, nbpb
  412. if (iconl(ib).eq.1) then
  413. ik1 = ik1 + 1
  414. nsym(ik1) = ib
  415. hg2.HCOOR((IK1-1)*3+1) = hg2.HCOOR((Ib-1)*3+1)
  416. hg2.HCOOR((IK1-1)*3+2) = hg2.HCOOR((Ib-1)*3+2)
  417. hg2.HCOOR((IK1-1)*3+3) = hg2.HCOOR((Ib-1)*3+3)
  418. HCOOR((IK1-1)*3+1) = HCOOR((Ib-1)*3+1)
  419. HCOOR((IK1-1)*3+2) = HCOOR((Ib-1)*3+2)
  420. HCOOR((IK1-1)*3+3) = HCOOR((Ib-1)*3+3)
  421.  
  422. endif
  423. enddo
  424. endif
  425. if (icle.ne.1) then
  426. NELS=IK1
  427. SEGADJ SHG,hg2,hg1
  428. endif
  429. C CALCUL DES NOEUDS DES SYM QU'ON STOCKE DANS HCOR2
  430. if (icle.ne.1) then
  431. SEGINI MCORD2
  432. imcord = mcord2
  433. SEGINI NOETR
  434. DO IB = 1, NELS
  435. ib1 = ib
  436. if (icle.eq.5) IB1 = NSYM(IB)
  437. if (icle.eq.4) IB1 = NSYM(IB)
  438. if (icle.eq.3) IB1 = NSYM(IB)
  439. IEL = IELH(IB1,1)
  440. IZO = IELH(IB1,2)
  441. imodel = kmodel(izo)
  442. ipmail = imamod
  443. nn2 = ipmail.num(/1)
  444. do ij = 1, nn2
  445. ino1=ipmail.num(ij,iel)
  446. IF (NDEJVU(INO1).EQ.0) THEN
  447. NDEJVU(INO1) = 1
  448. B = D
  449. if (icle.eq.5) then
  450. DO J = 1, idim
  451. B = B + XCOOR((ino1-1)*(idim+1)+J)*PT1(J)
  452. ENDDO
  453. B = B * 2
  454. DO J = 1, idim
  455. MCORD2.XCOOR((ino1-1)*(idim+1)+J) =
  456. + XCOOR((ino1-1)*(idim+1)+J) - B * PT1(J)
  457. enddo
  458. C
  459. elseif(icle.eq.4) then
  460. b=0D0
  461. DO J = 1, idim
  462. B = B + PT2(J)
  463. + * (xcoor((ino1-1)*(idim+1)+J)-PT1(J))
  464. ENDDO
  465.  
  466. DO J = 1, idim
  467. tata = +2*(PT1(J)-xcoor((ino1-1)*
  468. + (idim+1)+J)+B*PT2(J))
  469. titi=(xcoor((ino1-1)*(idim+1)+J))+tata
  470. MCORD2.XCOOR((ino1-1)*(idim+1)+J)=titi
  471. enddo
  472.  
  473. elseif(icle.eq.3) then
  474. DO J=1,idim
  475. MCORD2.XCOOR((ino1-1)*(idim+1)+J)=
  476. + xcoor((ino1-1)*(idim+1)+J)+2*(PT1(J)
  477. + -xcoor((ino1-1)*(idim+1)+J))
  478. ENDDO
  479. elseif(icle.eq.2) then
  480. DO J=1,idim
  481. MCORD2.XCOOR((ino1-1)*(idim+1)+J)=
  482. + xcoor((ino1-1)*(idim+1)+J)+PT1(J)
  483. ENDDO
  484. endif
  485. ENDIF
  486. enddo
  487. ENDDO
  488. endif
  489. C
  490. C debut du tri des projs
  491. C
  492. C
  493. C
  494. C
  495. segini hgt
  496. ihgt = hgt
  497. xmult = 3.1415926 * (xmax-xmin)
  498. ymult = 2.7182818 * (ymax-ymin)
  499. zmult = 1. * (zmax-zmin)
  500. tmult = sqrt(xmult**2+ymult**2+zmult**2)
  501. if (tmult.le.xpetit) then
  502. xmult = 3.1415926
  503. ymult = 2.7182818
  504. zmult = 1.
  505. tmult = sqrt(xmult**2+ymult**2+zmult**2)
  506. endif
  507. xmult = xmult / tmult
  508. ymult = ymult / tmult
  509. zmult = zmult / tmult
  510. tmin = xgrand
  511. tmax = -xgrand
  512. DO ib1 = 1, nels
  513. xproj = hg2.HCOOR((IB1-1)*3+1) * xmult
  514. + + HG2.HCOOR((IB1-1)*3+2) * ymult
  515. + + HG2.HCOOR((IB1-1)*3+3) * zmult
  516.  
  517. Xp(ib1) = xproj
  518. tmin = min(xproj,tmin)
  519. tmax = max(xproj,tmax)
  520. ico(ib1) = ib1
  521. ENDDO
  522. if (abs(tmin-tmax).le.xpetit) then
  523. tmin = tmin - 0.5
  524. tmax = tmax + 0.5
  525. endif
  526. if (ixlong.ne.0) xlong2 = xlong2m
  527. * quelques contorsions pour eviter un integer overflow
  528. xbzt = (tmax-tmin) / xlong2
  529. xbzt = max(xbzt,1.d0)
  530. xels=nels
  531. xbzt = min(xels,xbzt)
  532. nbzt=xbzt
  533.  
  534. CALL TRIFLO(Xp,Xw,ico,Ke,nels)
  535.  
  536. if (icle.eq.3) then
  537.  
  538. endif
  539. indt=nbzt+1
  540. segini mfopa
  541. imfopa = mfopa
  542. DO i = nels, 1, -1
  543. id = nbzt*(Xp(i)-tmin) / (tmax-tmin) + 1
  544. ind(id)=i
  545. ENDDO
  546. DO i = 1, nbzt
  547. if (ind(i+1).eq.0) ind(i+1)=ind(i)
  548. if(ind(i+1).lt.ind(i)) call erreur(5)
  549. ENDDO
  550. if (zthr) then
  551. ilon1 = nels / nbthr + 1
  552. else
  553. ilon1 = nels
  554. endif
  555. C jg = I232
  556. C jg1 = jg / nbthr
  557. C jg = jg1
  558. C double passage pour estimation taille de ivecti
  559. do ipas = 1, 2
  560. ipass = ipas
  561. if (ipas.eq.1) then
  562. segini mlhug
  563. ihug = mlhug
  564. endif
  565. C JG= ilon1 * nels
  566. C jg = min(jg,jg1)
  567. C khug = jg
  568. if (ipas.eq.2) then
  569. do i = 1, nbthr
  570. jg = nhug(i)
  571. segini ivecti
  572. ilhug(i) = ivecti
  573. nhug(i) = 0
  574. enddo
  575. endif
  576.  
  577. if (zthr) then
  578. call threadii
  579. do ith = 2, nbthr
  580. call threadid(ith,hselei)
  581. enddo
  582. call hselei(1)
  583. do ith = 2, nbthr
  584. call threadif(ith)
  585. enddo
  586. call threadis
  587. else
  588. call hsele1(1,1,nels,imfopa,ihg1,ihg2,iwrk3,ishg,ihug
  589. + ,ihgsel,ihg,ipmodl,icle,imcord,ihgt,ixlong)
  590. endif
  591. C fin de la boucle ipass
  592. enddo
  593. C
  594. C ecriture du chamelem resultat
  595. C
  596. N1=NSOUS
  597. L1=22
  598. N3=6
  599. SEGINI,MCHELM
  600. IPCHCO=MCHELM
  601. TITCHE='CONNECTIVITE NON LOCAL'
  602. IFOCHE=IFOUR
  603. DO ISOUS = 1, NSOUS
  604. IMODEL = KMODEL(ISOUS)
  605. IPMAIL = IMAMOD
  606. CONCHE(ISOUS) = CONSTI
  607. CONM = CONMOD
  608. NBEL = IPMAIL.NUM(/2)
  609. NBNN = IPMAIL.NUM(/1)
  610. C INFORMATIONS SUR L'ELEMENT FINI
  611. MELE=IPMAIL.ITYPEL
  612. IF (infmod(/1).lt.7) then
  613. CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  614. IF (IERR.NE.0) THEN
  615. GOTO 9999
  616. endif
  617. INFO=IPINF
  618. MINTE=INFELL(11)
  619. SEGSUP INFO
  620. ELSE
  621. minte=infmod(7)
  622. ENDIF
  623. C
  624. C COMPLEMENT DU CHAMELEM
  625. C
  626. IMACHE(ISOUS)=IPMAIL
  627. INFCHE(ISOUS,1)=0
  628. INFCHE(ISOUS,2)=0
  629. INFCHE(ISOUS,3)=NIFOUR
  630. INFCHE(ISOUS,4)=MINTE
  631. INFCHE(ISOUS,5)=0
  632. INFCHE(ISOUS,6)=5
  633.  
  634. C____________________________________________________________________
  635. C
  636.  
  637.  
  638. IF (ICLE.EQ.1) n2=4
  639. IF (ICLE.EQ.2.OR.ICLE.EQ.3) N2=5
  640. IF(ICLE.EQ.4.OR.ICLE.EQ.5) N2=6
  641. C TAILLE DES MELVALS A ALLOUER ET ALLOCATION
  642. C CREATION DU MCHAML DE LA SS ZONE
  643. C CAS SYMETRIE A PAS OUBLIER
  644. SEGINI MCHAML
  645. ICHAML(ISOUS) = MCHAML
  646. C CREATION DU PREMIER MELVAL
  647. C 'NLAR': DONNE LA LONGUEUR CARACTERISTIQUE
  648. C CE MELVAL EST CONSTANT DANS CHAQUE SS ZONE
  649. NOMCHE(1) = 'NLAR'
  650. TYPCHE(1) = 'REAL*8'
  651. N2PTEL = 0
  652. N2EL = 0
  653. C CAS CHAMP CARA
  654. if (ixlong.ne.0) then
  655. melval = imptv(isous)
  656. segini,melva1=melval
  657. ielval(1) = melva1
  658. else
  659. N1PTEL = 1
  660. N1EL = 1
  661. SEGINI, MELVAL
  662. IELVAL(1) = MELVAL
  663. VELCHE(1,1) = XLONG
  664. endif
  665. C CREATION DU DEUXIEME MELVAL
  666. C 'PMOD': PONTE SUR UN MODELE INDIQUANT LES ZONES GEOMETRIQUES
  667. C CE MELVAL EST CONSTANT
  668. N1PTEL = 0
  669. N1EL = 0
  670. N2PTEL = 1
  671. N2EL = 1
  672. NOMCHE(2) = 'PMOD'
  673. TYPCHE(2) = 'POINTEURMMODEL '
  674. SEGINI MELVAL
  675. IELVAL(2) = MELVAL
  676. IELCHE(1,1) = MMODEL
  677.  
  678. C 'NPNI : POINTE SUR UN LISTENTI CONTENANT LE NUMERO DU IMODEL
  679. C ACCESSIBLE POUR CHAQUE ELEMENT
  680. C 'NPLI': POINTE SUR UN LISTENTI CONTENANT UNE LINKED
  681. C LISTE DES ELEMENTS ACCESSIBLES SUR CHAQUE ZONE
  682.  
  683. N1EL = 0
  684. N1PTEL = 0
  685. N2PTEL = 1
  686. N2EL = NBEL
  687. NOMCHE(3) = 'NPNI'
  688. TYPCHE(3) = 'POINTEURLISTENTI'
  689. SEGINI, MELVAL
  690. IELVAL(3) = MELVAL
  691. NOMCHE(4) = 'NPLI'
  692. TYPCHE(4) = 'POINTEURLISTENTI'
  693. SEGINI, MELVAL
  694. IELVAL(4) = MELVAL
  695.  
  696.  
  697.  
  698. C
  699. C
  700. C 'POT1' : POINTE SUR UN OBJET DE TYPE POINT
  701. C
  702. C CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE
  703. C
  704. IF(ICLE.NE.1)THEN
  705. N1PTEL=0
  706. N1EL=0
  707. N2PTEL=1
  708. N2EL=1
  709. NOMCHE(5)='POT1'
  710. TYPCHE(5)='POINTEURPOINT '
  711. SEGINI MELVAL
  712. IELVAL(5)=MELVAL
  713. IELCHE(1,1)=JPT1
  714. ENDIF
  715. C
  716. C
  717. C 'POT2' : POINTE SUR UN OBJET DE TYPE POINT
  718. C
  719. C CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE
  720. C
  721. IF(ICLE.EQ.4)THEN
  722. N1PTEL=0
  723. N1EL=0
  724. N2PTEL=1
  725. N2EL=1
  726. NOMCHE(6)='POT2'
  727. TYPCHE(6)='POINTEURPOINT '
  728. SEGINI MELVAL
  729. IELVAL(6)=MELVAL
  730. IELCHE(1,1)=JPT2
  731. ENDIF
  732. C
  733. C 'DISP' : DONNE LA DISTANCE AU PLAN
  734. C
  735. C CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE
  736. C
  737. IF(ICLE.EQ.5)THEN
  738. N2PTEL=0
  739. N2EL=0
  740. N1PTEL=1
  741. N1EL=1
  742. NOMCHE(6)='DISP'
  743. TYPCHE(6)='REAL*8'
  744. SEGINI,MELVAL
  745. IELVAL(6)=MELVAL
  746. VELCHE(1,1)=D
  747. ENDIF
  748. C
  749. ENDDO
  750.  
  751.  
  752. C debut de la boucle pour ranger les numeros d element
  753.  
  754. DO IB1= 1, nbpb
  755. kzt(ib1) = 0
  756. knb=0
  757. DO ISOUS=1, NSOUS
  758. IF(inoa(IB1,ISOUS).NE.0) then
  759. kzt(ib1)=kzt(ib1)+1
  760. knb=knb+inoa(IB1,ISOUS)+1
  761. ENDIF
  762.  
  763. ENDDO
  764. IZO=IELH(IB1,2)
  765. IEL=IELH(IB1,1)
  766. MCHAML=ICHAML(IZO)
  767. if(iconl(ib1).eq.0.or.kzt(ib1).eq.0) then
  768. melval=ielval(3)
  769. ielche(1,iel)=0
  770. melval=ielval(4)
  771. ielche(1,IEL)=0
  772. else
  773. melval=ielval(3)
  774. jg=kzt(ib1)
  775. SEGINI MLENTI
  776. Ielche(1,Iel)=MLENTI
  777. melval=ielval(4)
  778. JG=KNB
  779. SEGINI MLENTI
  780. ielche(1,IEL)=MLENTI
  781. endif
  782. ENDDO
  783. C REMPLISSAGE DES LISTENTI
  784.  
  785. do ith = 1, nbthr
  786. ivecti = ilhug(ith)
  787. nbthr1 = nbthr
  788. if (ith.gt.nbthr1) goto 999
  789. ires = mod(nels,nbthr1)
  790. if (ires.eq.0) then
  791. ilon1 = nels / nbthr1
  792. ideb = (ith - 1) * ilon1 + 1
  793. else
  794. if (ith.le.ires) then
  795. ilon1 = nels / nbthr1 + 1
  796. ideb = (ith - 1) * ilon1 + 1
  797. else
  798. ilon1 = nels / nbthr1
  799. ideb = (ires * (ilon1 + 1)) + (ith - ires - 1)*ilon1+1
  800. endif
  801. endif
  802. ifin = ideb + ilon1 - 1
  803. if (ifin.ge.ideb) then
  804. ICP=0
  805. DO iIB1=ideb, ifin
  806. ib1 = iib1
  807. if (icle.eq.3.or.icle.eq.4.or.icle.eq.5) ib1=nsym(iib1)
  808. if (iconl(IB1).eq.1.and.kzt(ib1).ne.0) then
  809. KZTl=0
  810. IEL=IELH(IB1,1)
  811. IZO=IELH(IB1,2)
  812. MCHAML=ICHAML(IZO)
  813. MELVAL=IELVAL(3)
  814. MLENTI=IELCHE(1,IEL)
  815. MELVAL=IELVAL(4)
  816. MLNIMO=IELCHE(1,IEL)
  817. N1=MLNIMO.LECT(/1)
  818. NCP1=0
  819. NTOT=0
  820. DO ISOUS=1, NSOUS
  821. IF (INOA(IB1,ISOUS).NE.0) THEN
  822. NTOT=NTOT+INOA(IB1,ISOUS)
  823. NCP=INOA(IB1,ISOUS)
  824.  
  825. NCP1=NCP1+1
  826. MLNIMO.LECT(NCP1)=INOA(IB1,ISOUS)
  827.  
  828. KZTl=KZTl+1
  829. MLENTI.LECT(KZTl)=ISOUS
  830. DO I1=1, INOA(IB1,NSOUS+1)
  831. IB2=LHUG(ICP+I1)
  832. IZO2=IELH(IB2,2)
  833. IF (IZO2.EQ.ISOUS) THEN
  834. IEL2=IELH(IB2,1)
  835. NCP1=NCP1+1
  836. MLNIMO.LECT(NCP1)=IEL2
  837. ENDIF
  838. ENDDO
  839. ENDIF
  840.  
  841. ENDDO
  842. ICP=ICP+NTOT
  843. endif
  844. C fin de la boucle sur les éléments
  845. ENDDO
  846. endif
  847. 999 continue
  848. C fin de la boucle sur nbthr
  849. segsup ivecti
  850. enddo
  851.  
  852.  
  853. segsup mlhug
  854. segsup hg1,hgt,hg,conl
  855. do ii = 1, nsous
  856. do i = 1, nbthr
  857. wrk1 =iwrk1(ii,i)
  858. wrk2 =iwrk2(ii,i)
  859. segsup wrk1,wrk2
  860. enddo
  861. enddo
  862. segsup wrk3
  863. segsup mfopa
  864. segsup ivecti
  865. segsup kkzt
  866. if (icle.ne.1) then
  867. segsup hg2,shg,noetr,mcord2
  868. endif
  869. c
  870. C desactivation de l'objet resultat pour qu'il ne soit plus actif en ecriture
  871. C ce qui n'a pas ete cree dans la routine est laisse ouvert
  872. c
  873.  
  874. mchelm = ipchco
  875. do isous = 1, nsous
  876. mchaml = ichaml(isous)
  877. melval = ielval(1)
  878. segdes melval
  879. melval = ielval(2)
  880. segdes melval
  881. if (icle.ne.1) then
  882. melval = ielval(5)
  883. segdes melval
  884. endif
  885. if (icle.eq.4.or.icle.eq.5) then
  886. melval = ielval(6)
  887. segdes melval
  888. endif
  889. melval = ielval(3)
  890. do jj = 1, ielche(/2)
  891. if (ielche(1,jj).ne.0) then
  892. mlenti = ielche(1,jj)
  893. segdes mlenti
  894. endif
  895. enddo
  896. segdes melval
  897. melval = ielval(4)
  898. do jj = 1, ielche(/2)
  899. if (ielche(1,jj).ne.0) then
  900. mlenti = ielche(1,jj)
  901. segdes mlenti
  902. endif
  903. enddo
  904. segdes melval
  905. segdes mchaml
  906. enddo
  907. segdes mchelm
  908.  
  909. if (zthr) then
  910. call threadis
  911. endif
  912. return
  913. C____________________________________________________________________
  914. C
  915. C ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  916. C____________________________________________________________________
  917. C
  918. 9999 CONTINUE
  919. IF(ISOUS.GT.1)THEN
  920. DO IE1=1,ISOUS
  921. CALL DTSHAM(ICHAML(IE1))
  922. ENDDO
  923. ENDIF
  924. SEGSUP,MCHELM
  925. IPCHCO=0
  926. IRET=0
  927. C
  928. DO IE1=1,NSOUS
  929. IMODEL=KMODEL(IE1)
  930. IPMAIL=IMAMOD
  931. SEGDES,IPMAIL,IMODEL
  932. ENDDO
  933. SEGDES,MMODEL
  934. RETURN
  935. C
  936. END
  937.  
  938.  
  939.  
  940.  
  941.  
  942.  
  943.  
  944.  
  945.  
  946.  
  947.  

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