Télécharger excit1.eso

Retour à la liste

Numérotation des lignes :

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

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