Télécharger excit1.eso

Retour à la liste

Numérotation des lignes :

  1. C EXCIT1 SOURCE CB215821 19/08/20 21:17:18 10287
  2.  
  3. SUBROUTINE EXCIT1(MRIGID,MCHPO1,MCHPO2,MCHPO3,MLENTI,indic,RI2,
  4. & ipt8,ITYP)
  5.  
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8(A-H,O-Z)
  8.  
  9. * modif : declarer inactifs les blocages redondants s'ils sont dans
  10. * ipt8. Si celui-ci est non vide, on enleve les blocages inclus
  11. * dedans et on s'en tient la.
  12.  
  13. -INC CCOPTIO
  14. -INC CCREEL
  15. -INC CCGEOME
  16.  
  17. -INC SMRIGID
  18. -INC SMCHPOI
  19. -INC SMELEME
  20. -INC SMCOORD
  21. -INC SMLENTI
  22.  
  23. SEGMENT SNOMIN
  24. CHARACTER*4 NOMIN(0)
  25. ENDSEGMENT
  26. SEGMENT ISOU(IRIGEL(/2))
  27. SEGMENT ICPR(XCOOR(/1)/idimp1)
  28. SEGMENT JCPR(XCOOR(/1)/idimp1)
  29. SEGMENT KCPR(XCOOR(/1)/idimp1)
  30. SEGMENT YCPR(XCOOR(/1)/idimp1)
  31. SEGMENT ITRAV
  32. real*8 DVAL(NIN,NPO),DIN(NPO)
  33. integer IEXI(NIN,NPO)
  34. endsegment
  35. SEGMENT IPASS(ITEMP)
  36. segment trav1
  37. integer iav(nbo)
  38. real*8 viol(nbo)
  39. endsegment
  40. C
  41. C *** ICPR REFERENCIE DVAL
  42. C *** NOMIN CONTIENT LES INCONNUES REFERENCES PAR LES RELATIONS
  43. C *** DVAL CONTIENT LE RESULTAT DES DEPLACEMENTS ET DES LAMBDA
  44. C *** DIN CONTIENT LES VALEURS INITIALES DU SECOND MEMBRE
  45. C
  46. logical indic
  47. C
  48. idimp1 = idim+1
  49. segact,mcoord
  50. C
  51. xcrot = 0.
  52. XMCRIT = xpetit*1d10
  53. YMCRIT = xpetit*1d10
  54. ymult = 1.
  55. ** if (ityp.eq.3) ymult=1.D2
  56. if (ityp.eq.2) xcrot=0.250
  57.  
  58. icpr=0
  59. jcpr=0
  60. ycpr=0
  61. kcpr=0
  62. itrav=0
  63.  
  64. * on a un maillage de relation(s) a enlever
  65. if (ipt8.ne.0) then
  66. segact,ipt8
  67. if (ipt8.itypel.ne.1) then
  68. call erreur(16)
  69. return
  70. endif
  71. if (ipt8.num(/2).ne.0) then
  72. segini,kcpr
  73. do i=1,ipt8.num(/2)
  74. kcpr(ipt8.num(1,i))=1
  75. enddo
  76. endif
  77. endif
  78. *
  79. * mchpo3 est le champ des LX sorti de excfro jcpr donne existence
  80. * et ycpr donne valeur
  81. * write (ioimp,*) ' mchpo3 dans excit1 ',mchpo3
  82. if (mchpo3.ne.0) then
  83. segini,jcpr,ycpr
  84. segact,mchpo3
  85. do 100 isoupo=1,mchpo3.ipchp(/1)
  86. msoupo=mchpo3.ipchp(isoupo)
  87. segact,msoupo
  88. do 110 ic=1,nocomp(/2)
  89. if (nocomp(ic).eq.'LX ') goto 120
  90. 110 continue
  91. goto 140
  92. 120 continue
  93. ipt2=igeoc
  94. mpoval=ipoval
  95. segact,ipt2,mpoval
  96. do 130 iel=1,ipt2.num(/2)
  97. impt=ipt2.num(1,iel)
  98. jcpr(impt)=1
  99. ycpr(impt)=ycpr(impt)+vpocha(iel,ic)
  100. 130 continue
  101. 140 continue
  102. 100 continue
  103. endif
  104. C
  105. C** INITIALISATION DE NOMIN ET ICPR icpr repere les points appartenant
  106. C** a la matrice de blocage mini maxi ou ?
  107. C
  108. SEGINI,SNOMIN,ICPR
  109. NOMIN(**)='LX '
  110. NPO=0
  111. NBO=0
  112. *
  113. SEGACT,MRIGID
  114. DO 1 I=1,IRIGEL(/2)
  115. ITY=IRIGEL(6,I)
  116. IF (ITY.EQ.0) GO TO 1
  117. * cas du frottement : petite verification
  118. if (ity.eq.2 .and. mchpo3.eq.0) then
  119. call erreur(721)
  120. return
  121. endif
  122. MELEME=IRIGEL(1,I)
  123. SEGACT,MELEME
  124. NBO=NBO+NUM(/2)
  125. IF(IIMPI.EQ.528) WRITE(IOIMP,3765) NBO
  126. 3765 FORMAT(' NBO ',I5)
  127. DO 2 J=1,NUM(/2)
  128. DO 2 K=1,NUM(/1)
  129. impt=NUM(K,J)
  130. IF (ICPR(impt).EQ.0) THEN
  131. NPO=NPO+1
  132. ICPR(impt)=NPO
  133. ENDIF
  134. 2 CONTINUE
  135. DESCR=IRIGEL(3,I)
  136. SEGACT,DESCR
  137. DO 3 J=1,LISINC(/2)
  138. DO 4 K=1,NOMIN(/2)
  139. IF (NOMIN(K).EQ.LISINC(J)) GO TO 3
  140. 4 CONTINUE
  141. NOMIN(**)=LISINC(J)
  142. 3 CONTINUE
  143. SEGDES,DESCR
  144. 1 CONTINUE
  145. NIN=NOMIN(/2)
  146. *
  147. IF(IIMPI.EQ.528) THEN
  148. WRITE(ioimp,90) NPO
  149. WRITE(IOIMP,9876)( NOMIN(i),i=1,NIN)
  150. 90 FORMAT(' ON VIENT DE PASSER LA BOUCLE 1 NPO ',I5)
  151. 9876 FORMAT(' NOMIN ' ,10(A4,1X))
  152. ENDIF
  153. C
  154. C **** ON REMPLIT DVAL AVEC LES VALEURS DE MCHPO2
  155. C mchpo2 est le champ de deplacement propose par RESOU
  156. C dval(j,icpr(i)) est la j eme composante du deplacement du point i
  157. C et iexi(j,icpr(i))=1
  158. C
  159. SEGINI,ITRAV
  160. c
  161. MCHPOI=MCHPO2
  162. SEGACT,MCHPOI
  163. DO 5 I=1,IPCHP(/1)
  164. MSOUPO=IPCHP(I)
  165. SEGACT,MSOUPO
  166. MELEME=IGEOC
  167. SEGACT,MELEME
  168. ITEMP=NOCOMP(/2)
  169. SEGINI,IPASS
  170. DO 6 K=1,ITEMP
  171. DO 7 J=1,NIN
  172. IF (NOMIN(J).EQ.NOCOMP(K)) THEN
  173. IPASS(K)=J
  174. GO TO 6
  175. ENDIF
  176. 7 CONTINUE
  177. 6 CONTINUE
  178. IF (IIMPI.EQ.528) WRITE(IOIMP,1555) (IPASS(KHU),KHU=1,ITEMP)
  179. 1555 FORMAT(' IPASS ' ,9I10)
  180. MPOVAL=IPOVAL
  181. SEGACT,MPOVAL
  182. III=0
  183. DO 8 J=1,ITEMP
  184. K=IPASS(J)
  185. IF (K.EQ.0) GO TO 8
  186. DO 9 L=1,NUM(/2)
  187. IP=ICPR(NUM(1,L))
  188. IF (IP.EQ.0) GO TO 9
  189. * if (k.eq.1.and.vpocha(l,j).eq.0.d0 ) then
  190. * write (6,*) 'LX nul dans excit1'
  191. * goto 9
  192. * endif
  193. DVAL(K,IP)=dval(k,ip)+VPOCHA(L,J)
  194. IEXI(K,IP)=1
  195. III=III+1
  196. 9 CONTINUE
  197. 8 CONTINUE
  198. SEGSUP,IPASS
  199. 5 CONTINUE
  200. *
  201. IF (IIMPI.EQ.528) then
  202. WRITE(IOIMP,1556)III,(DVAL(1,i),i=1,NPO)
  203. WRITE(IOIMP,101)
  204. 1556 FORMAT(' III DVAL ',I6,/,(1X,10E12.5))
  205. 101 FORMAT(' ON VIENT DE PASSER LA BOUCLE 5')
  206. endif
  207. C
  208. C **** ON REMPLIT DIN PAR LES VALEURS DE MCHPO1 POUR LES LAMBDAS
  209. C mchpo1 est le vecteur initial FLX ( deplacement initial)
  210. C din (icpr(i)) est le deplacement (FLX) initial du point i
  211. C
  212. MCHPOI=MCHPO1
  213. SEGACT,MCHPOI
  214. DO 10 i=1,IPCHP(/1)
  215. MSOUPO=IPCHP(I)
  216. SEGACT,MSOUPO
  217. MELEME=IGEOC
  218. SEGACT,MELEME
  219. MPOVAL=IPOVAL
  220. SEGACT,MPOVAL
  221. DO 11 J=1,NOCOMP(/2)
  222. IF (NOCOMP(J).NE.'FLX ') GO TO 11
  223. DO 12 K=1,NUM(/2)
  224. IP=ICPR(NUM(1,K))
  225. IF (IP.EQ.0) GO TO 12
  226. DIN(IP)=VPOCHA(K,J)
  227. 12 CONTINUE
  228. 11 CONTINUE
  229. 10 CONTINUE
  230. *
  231. IF (IIMPI.EQ.528) then
  232. WRITE(IOIMP,102)
  233. WRITE(IOIMP,666) (DIN(i),i=1,NPO)
  234. 102 FORMAT(' ON VIENT DE PASSER LA BOUCLE 10')
  235. 666 FORMAT(' DIN ',/,(1X,10E12.5))
  236. ENDIF
  237. C
  238. C **** ON BOUCLE SUR LES RIGIDITE ET ON TESTE:
  239. C **** SI LE MULTI EXISTE DANS DVAL SON SIGNE PAR RAPPORT A IRIGEL(6,I)
  240. C **** SINON ON TESTE LA RELATION ELLE MEME A L'AIDE DES COEFF
  241. C **** DE LA MATRICE ET DE LA VALEUR DU LAMBDA INI (DANS DIN)
  242. C **** ON CREE UN TABLEAU CONTENANT LE NUMERO DES MATRICES A GARDER ET
  243. C **** LE NUMERO DE LA SOUS RIGIDITE
  244. IPA=0
  245. JG=NBO
  246. SEGINI,MLENTI,trav1
  247. DO 313 I=1,IRIGEL(/2)
  248. ITY=IRIGEL(6,I)
  249. IF (ITY.EQ.0) GO TO 313
  250. MELEME=IRIGEL(1,I)
  251. SEGACT,MELEME
  252. DESCR=IRIGEL(3,I)
  253. SEGACT,DESCR
  254. DO 314 J=1,LISINC(/2)
  255. IF(LISINC(J).EQ.'LX ') GO TO 315
  256. 314 CONTINUE
  257. CALL ERREUR(5)
  258. RETURN
  259. 315 CONTINUE
  260. xmatri=irigel(4,i)
  261. segact,xmatri
  262. JJ=NOELEP(J)
  263. ITEMP=LISINC(/2)
  264. SEGINI,IPASS
  265. DO 316 J=1,ITEMP
  266. DO 317 K=1,NIN
  267. IF(LISINC(J).NE.NOMIN(K)) GO TO 317
  268. IPASS(J)=K
  269. GO TO 316
  270. 317 CONTINUE
  271. CALL ERREUR (5)
  272. RETURN
  273. 316 CONTINUE
  274. * RECHERCHE DU MAX DES LAMDAS POUR LE CRITERE DE DECOLLEMENT D'APPUI
  275. * RECHERCHE DU MAX DES DEPLACEMENT POUR LE CRITERE DE TRAVERSEE D'APPUI
  276. * ymcrit est le deplacement maxi de tous les points en relation unilateral
  277. * xmcrit est le maxi des multiplicateurs existant dans le chpoin de depla
  278. * remarque : ce chpoint de depla contient les multiplicateurs de contact
  279. * (pression)
  280. DO 30 J=1,NUM(/2)
  281. iel=j
  282. IP=ICPR(NUM(JJ,J))
  283. DO 31 K=1,ITEMP
  284. IF(LISINC(K).EQ.'LX ') GO TO 31
  285. IPPP=NUM(NOELEP(K),J)
  286. IPP=ICPR(IPPP)
  287. * deplacement
  288. YMCRIT=MAX(YMCRIT,ABS(DVAL(IPASS(K),IPP)))
  289. 31 CONTINUE
  290. * jeu
  291. YMCRIT=MAX(YMCRIT,ABS(DIN(IP)))
  292. IF (IEXI(1,IP).EQ.0) GOTO 30
  293. XMCRIT=MAX(XMCRIT,ABS(DVAL(1,IP)))
  294. 30 CONTINUE
  295. * write (6,*) ' xmcrit ymcrit apres 30 ',xmcrit,ymcrit
  296. SEGSUP,IPASS
  297. * on rajoute dans ymcrit la dimension de l'element
  298. * write (6,*) ' avant 32 ymcrit num(/2) ',ymcrit,num(/2),num(/1),
  299. * > re(/1),re(/3)
  300. do 32 j=1,num(/2)
  301. iel=j
  302. if (idim.eq.3) then
  303. ip1=num(1,iel)
  304. ip2=num(2,iel)
  305. ip3=num(2,iel)
  306. xp1=xcoor((ip1-1)*4+1)
  307. yp1=xcoor((ip1-1)*4+2)
  308. zp1=xcoor((ip1-1)*4+3)
  309. xp2=xcoor((ip2-1)*4+1)
  310. yp2=xcoor((ip2-1)*4+2)
  311. zp2=xcoor((ip2-1)*4+3)
  312. xp3=xcoor((ip3-1)*4+1)
  313. yp3=xcoor((ip3-1)*4+2)
  314. zp3=xcoor((ip3-1)*4+3)
  315. xcr3=(xp2-xp1)**2+(yp2-yp1)**2+(zp2-zp1)**2
  316. xcr1=(xp3-xp2)**2+(yp3-yp2)**2+(zp3-zp2)**2
  317. xcr2=(xp1-xp3)**2+(yp1-yp3)**2+(zp1-zp3)**2
  318. xcr=sqrt(max(xcr1,xcr2,xcr3))
  319. else if (idim.eq.2) then
  320. ip1=num(1,iel)
  321. ip2=num(2,iel)
  322. xp1=xcoor((ip1-1)*3+1)
  323. yp1=xcoor((ip1-1)*3+2)
  324. xp2=xcoor((ip2-1)*3+1)
  325. yp2=xcoor((ip2-1)*3+2)
  326. xcr2=(xp2-xp1)**2+(yp2-yp1)**2
  327. xcr=sqrt(xcr2)
  328. else
  329. xcr = 0.D0
  330. endif
  331. ymcrit=max(ymcrit,xcr)
  332. 32 continue
  333. 313 CONTINUE
  334. *
  335. if (mchpo3.ne.0) then
  336. * write (6,*) ' excit1 xmcrit avant ',xmcrit
  337. do ip=1,ycpr(/1)
  338. xmcrit=max(xmcrit,abs(ycpr(ip)))
  339. enddo
  340. * write (6,*) ' excit1 xmcrit apres ',xmcrit
  341. endif
  342.  
  343. XMCRIT=1D-10 *XMCRIT
  344. YMCRIT=1D-10 *YMCRIT
  345. * write (6,*) ' xmcrit ymcrit ',xmcrit,ymcrit
  346. * Critere en cas de frottement
  347. yfcrit = YMCRIT*ymult
  348.  
  349. * Strategie lente plus laxiste
  350. if (ityp.eq.3) then
  351. xmcrit = xmcrit * 1d4
  352. ymcrit = ymcrit * 1d4
  353. yfcrit = yfcrit * 1d4
  354. endif
  355. *
  356. DO 13 I=1,IRIGEL(/2)
  357. ITY=IRIGEL(6,I)
  358. IF (ITY.EQ.0) GO TO 13
  359. MELEME=IRIGEL(1,I)
  360. SEGACT,MELEME
  361. DESCR=IRIGEL(3,I)
  362. SEGACT,DESCR
  363. xMATRI=IRIGEL(4,I)
  364. SEGACT,xMATRI
  365. ITEMP=LISINC(/2)
  366. SEGINI,IPASS
  367. DO 14 J=1,ITEMP
  368. IF (LISINC(J).EQ.'LX ') GO TO 15
  369. 14 CONTINUE
  370. CALL ERREUR(5)
  371. RETURN
  372. 15 CONTINUE
  373. JJ=NOELEP(J)
  374. DO 16 J=1,ITEMP
  375. DO 17 K=1,NIN
  376. IF(LISINC(J).NE.NOMIN(K)) GO TO 17
  377. IPASS(J)=K
  378. GO TO 16
  379. 17 CONTINUE
  380. CALL ERREUR (5)
  381. RETURN
  382. 16 CONTINUE
  383. DO 18 J=1,NUM(/2)
  384. IPA=IPA+1
  385. IPT=NUM(JJ,J)
  386. IP=ICPR(IPT)
  387. ityz=0
  388. * eliminer condition redondantes pour le pas d'apres
  389. if (kcpr.ne.0) then
  390. if (kcpr(num(noelep(1),j)).ne.0) then
  391. goto 18
  392. endif
  393. endif
  394. C
  395. C ** CAS OU LE BLOQUAGE N'ETAIT PAS SOLLICITE
  396. C
  397. IF (IEXI(1,IP).EQ.0) THEN
  398. SS=0.D0
  399. remax=0.d0
  400. DO 19 K=1,ITEMP
  401. IF (LISINC(K).EQ.'LX ') GO TO 19
  402. remax=max(remax,abs(re(1,k,j)))
  403. if (ipass(k).eq.0) goto 19
  404. IPPP=NUM(NOELEP(K),J)
  405. IPP=ICPR(IPPP)
  406. if (ipp.eq.0) goto 19
  407. * write (6,*) ' k dval re ss',dval(ipass(k),ipp),
  408. * > re(1,k,j),ss
  409. SS = DVAL(IPASS(K),IPP) * RE(1,K,j) + SS
  410. 19 CONTINUE
  411. IF (IIMPI.EQ.528) WRITE(IOIMP,529) IPPP,SS
  412. 529 FORMAT( ' LIBRE ',I5,2X,E12.5)
  413. r_z = ABS(din(ip))*1.D-10
  414. * write (6,*) 'r_z ymcrit ss',r_z,ymcrit,remax,ss
  415. r_p1 = DIN(IP) + r_z
  416. r_m1 = DIN(IP) - r_z
  417. * cas du frottement
  418. if (ity.eq.2) then
  419. ityz=jcpr(ipt)
  420. * write(ioimp,*) 'ipt jcpr ycpr ',ipt,jcpr(ipt),ycpr(ipt)
  421. if (ityz.ne.0) ityz=sign(1.1D0,ycpr(ipt))
  422. * if (ityz.eq.0) write (6,*) ' frottement -1 tyz ',ityz
  423. * write(ioimp,*) '1 dans excite ityz ',ityz
  424. * apparamment il faut etre plus laxiste pour le frottement
  425. * peut etre pas finalement
  426. if (ityz.eq.0) goto 20
  427. IF (ITYz.EQ. 1.AND.SS.LE.r_p1+yfcrit*remax) GOTO 20
  428. IF (ITYz.EQ.-1.AND.SS.GE.r_m1-yfcrit*remax) GOTO 20
  429. endif
  430. IF (ITY.EQ. 1.AND.SS.LE.r_p1+YMCRIT*remax) GOTO 20
  431. IF (ITY.EQ.-1.AND.SS.GE.r_m1-YMCRIT*remax) GOTO 20
  432. LECT(IPA)=1
  433. viol(ipa)=ss-din(ip)
  434. if (iimpi.eq.1967)
  435. > write (6,*) ' ss din ymcrit nouveau blocage '
  436. $ ,ss,din(ip),ymcrit,ipa,viol(ipa),ipt,ityz,ityp
  437. * on a un (1) nouveau blocage on arrete
  438. 20 CONTINUE
  439. C
  440. C ** CAS OU LE BLOQUAGE ETAIT SOLLICITE PETIT PROBLEME DE TEST DE
  441. C PRECISION SUR LA VALEUR DE LA REACTION
  442. C
  443. ELSE
  444. iav(ipa)=1
  445. SS=DVAL(1,IP)
  446. * write (6,*) ' ss xmcrit ',ss,xmcrit
  447. IF(IIMPI.EQ.528) WRITE(IOIMP,530) NUM(JJ,J),SS
  448. 530 FORMAT(' BLOQUER ' ,I5,2X,E12.5)
  449. * cas du frottement
  450. if (ity.eq.2) then
  451. ityz=jcpr(ipt)
  452. if (ityz.ne.0) ityz=sign(1.1D0,ycpr(ipt))
  453. * if (ityz.eq.0) write (6,*) ' frottement -2 ityz ',ityz
  454. * apparamment il faut etre plus laxiste pour le frottement
  455. * peut etre pas finalement
  456. if (ityz.eq.0) goto 21
  457. IF(ITYz.EQ.1.AND.SS.LT. -XMCRIT) GO TO 21
  458. IF(ITYz.EQ.-1.AND.SS.GT.+XMCRIT) GO TO 21
  459. endif
  460. IF(ITY.EQ.1.AND.SS.LT. -XMCRIT) GO TO 21
  461. IF(ITY.EQ.-1.AND.SS.GT.+XMCRIT) GO TO 21
  462. LECT(IPA)=1
  463. goto 18
  464. 21 CONTINUE
  465. viol(ipa)=ss
  466. C write (6,*) ' ss xmcrit ',ss,xmcrit,ityz,i,ipa,
  467. C > num(3,j),num(4,j),num(5,j)
  468. if (iimpi.eq.1967)
  469. > write (6,*) ' appui disparait '
  470. $ ,ss,din(ip),ymcrit,ipa,viol(ipa),ipt,ityz,ityp
  471. ENDIF
  472. 18 CONTINUE
  473. SEGSUP,IPASS
  474. SEGDES,DESCR,xMATRI
  475. 13 CONTINUE
  476. IF(IIMPI.EQ.528) WRITE(IOIMP,*) 'ON VIENT DE PASSER LA BOUCLE 13'
  477. C
  478. C **** DANS LECT ON DIT SI LA JEEME RIGI ELEMTAIRE EST A CONSERVER
  479. C
  480. NRIGEL=IRIGEL(/2)
  481. SEGINI,RI2
  482. C
  483. C **** CAS OU IL N'Y A RIEN A GARDER ON CREE UNE RIGIDITE VIDE
  484. C **** POUR POUVOIR CONTINUER D'ITERER SI IL Y A LIEU
  485. C
  486. IF (NRIGEL.EQ.0) THEN
  487. IF (IIMPI.EQ.528) WRITE(IOIMP,*) ' IL N''Y A RIEN A CREER'
  488. GO TO 50
  489. ENDIF
  490. *
  491. *** ne garder que ce qui viole de plus de xcrot du max
  492. *
  493. * recherche du max
  494. violmf=0.
  495. violmd=0.
  496. imf=0
  497. imd=0
  498. do 40 i=1,nbo
  499. violm=abs(viol(i))
  500. if (iav(i).eq.0.and.lect(i).ne.0) then
  501. if (violm.gt.violmd) then
  502. violmd=violm
  503. imd=i
  504. endif
  505. else if (iav(i).eq.1.and.lect(i).ne.1) then
  506. if (violm.gt.violmf) then
  507. violmf=violm
  508. imf=i
  509. endif
  510. endif
  511. 40 continue
  512. * write (6,*) ' ityp xcrot violmd violmf ',ityp,xcrot,
  513. * > violmd,violmf,imd,imf
  514. rvd = 0.70*violmd
  515. rvf = 0.90*violmf
  516. if (ityp.eq.3) then
  517. rvd = 0.98*violmd
  518. rvf = 0.98*violmf
  519. rvd = 0.9999*violmd
  520. rvf = 0.9999*violmf
  521. endif
  522. idjf=0
  523. do 41 i=1,nbo
  524. violm=abs(viol(i))
  525. * if (ityp.ne.3) then
  526. if (imf.ne.0.and.iav(i).eq.0) lect(i)=0
  527. if (iav(i).eq.0.and.violm.ge.rvd) goto 41
  528. if (iav(i).eq.1) goto 41
  529. * else
  530. * if (imd.ne.0.and.iav(i).eq.1) lect(i)=1
  531. * if (iav(i).eq.1.and.violm.ge.rvf) goto 41
  532. * if (iav(i).eq.0) goto 41
  533. *** if (iav(i).ne.lect(i).and.idjf.eq.0) then
  534. *** idjf=1
  535. *** goto 41
  536. *** endif
  537.  
  538. * endif
  539. lect(i)=iav(i)
  540. 41 continue
  541. **** endif
  542. C
  543. C ** IL FAUT CREER UNE RIGIDITE
  544. C
  545. IPA= 0
  546. IRI=0
  547. DO 25 I =1,IRIGEL(/2)
  548. IF(IRIGEL(6,I).EQ.0) GO TO 25
  549. MELEME=IRIGEL(1,I)
  550. SEGACT,MELEME
  551. NELRIG=0
  552. DO 27 J=1,NUM(/2)
  553. IF(LECT(IPA+J).EQ.1) NELRIG=NELRIG+1
  554. 27 CONTINUE
  555. if (nelrig.eq.0) goto 26
  556. IRI=IRI+1
  557. xMATRI=IRIGEL(4,I)
  558. SEGACT,xMATRI
  559. nligrp=re(/2)
  560. nligrd=re(/1)
  561. SEGINI,xMATR1
  562. RI2.IRIGEL(4,IRI)=xMATR1
  563. RI2.IRIGEL(3,IRI)=IRIGEL(3,I)
  564. RI2.IRIGEL(5,IRI)=IRIGEL(5,I)
  565. RI2.IRIGEL(6,IRI)=IRIGEL(6,I)
  566. RI2.COERIG(IRI)=COERIG(I)
  567. NBNN =NUM(/1)
  568. NBELEM=NELRIG
  569. NBSOUS=0
  570. NBREF =0
  571. SEGINI,IPT1
  572. IPT1.ITYPEL=ITYPEL
  573. RI2.IRIGEL(1,IRI)=IPT1
  574. I2=0
  575. DO 28 J=1,NUM(/2)
  576. IF(LECT(IPA+J).EQ.0) GO TO 28
  577. I2=I2+1
  578. DO 29 K=1,NUM(/1)
  579. IPT1.NUM(K,I2)=NUM(K,J)
  580. 29 CONTINUE
  581. do io=1,nligrp
  582. do iu=1,nligrd
  583. xmatr1.re(iu,io,i2)=re(iu,io,j)
  584. enddo
  585. enddo
  586. ** if (ityp.eq.3.and.iav(ipa+j).eq.0) then
  587. ** write (6,*) ' excit1 augmentation ',ipa+j
  588. ** xmatr1.re(1,1,i2)=-0.5
  589. ** endif
  590.  
  591. 28 CONTINUE
  592. SEGDES,xMATR1,xMATRI
  593. 26 CONTINUE
  594. IPA=IPA+NUM(/2)
  595. 25 CONTINUE
  596. *
  597. if (iri.ne.ri2.irigel(/2)) then
  598. nrigel=iri
  599. segadj,ri2
  600. endif
  601.  
  602. 50 CONTINUE
  603. SEGDES,RI2,MRIGID
  604.  
  605. * indice de retour
  606. indic = .true.
  607. do 55 i = 1, nbo
  608. if (iav(i).ne.lect(i)) indic = .false.
  609. 55 continue
  610. ** do il=1,lect(/1),5
  611. ** write (6,*)' mlenti ',(lect(ill),ill=il,min(lect(/1),il+4))
  612. ** enddo
  613.  
  614. SEGSUP,SNOMIN,ICPR,ITRAV,trav1
  615. if (mchpo3.ne.0) segsup,jcpr,ycpr
  616. if (kcpr.ne.0) segsup,kcpr
  617.  
  618. END
  619.  
  620.  
  621.  

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