Télécharger bloque.eso

Retour à la liste

Numérotation des lignes :

  1. C BLOQUE SOURCE BP208322 16/11/18 21:15:15 9177
  2.  
  3. C-----------------------------------------------------------------------
  4. C Cet operateur impose les BLOCAGES
  5. C
  6. C Syntaxe :
  7. C
  8. C ENC1 = BLOQUER ( DEPL ) ( ROTA ) POI1
  9. C
  10. C ou ENC1 = BLOQUER RADIAL P1 (P2) MELEME
  11. C ORTHOR P1 (P2) MELEME
  12. C
  13. C ou ENC1 = BLOQUER (DEPL) (ROTA) DIRECTION V1 MELEME
  14. C
  15. C DIM = 1 ( UX UY UZ ) ou ( UR UZ ) |
  16. C DIM = 2 OU 3 ( UX UY UZ RX RY RZ ) | MELEME
  17. C AXISYM ( RX RZ RT UT ) |
  18. Clist t
  19. C POI1 = OBJET DE TYPE POINT (entree)
  20. C MELEME = OBJET DE TYPE MELEME (entree)
  21. C ENC1 = OBJET DE TYPE RIGIDITE (sortie)
  22. C
  23. C 1) On peut imposer des BLOQUAGES UNILATERAUX en specifiant les
  24. C mots-cles MINIMUM ou MAXIMUM.
  25. C 2) On peut imposer des BLOQUAGES de type FROTTEMENT en specifiant
  26. C le mot-cle FROTTEMENT.
  27. C-----------------------------------------------------------------------
  28. C Juillet 2003 : passage a un seul multiplicateur
  29. C-----------------------------------------------------------------------
  30.  
  31. SUBROUTINE BLOQUE
  32.  
  33. IMPLICIT INTEGER(I-N)
  34. IMPLICIT REAL*8 (A-H,O-Z)
  35.  
  36. -INC CCOPTIO
  37. -INC CCGEOME
  38. -INC CCREEL
  39. -INC CCHAMP
  40.  
  41. -INC SMCHPOI
  42. -INC SMCOORD
  43. -INC SMELEME
  44. -INC SMLMOTS
  45. POINTEUR LMDEPL.MLMOTS
  46. -INC SMMODEL
  47. -INC SMRIGID
  48. -INC SMTABLE
  49. -INC TMTRAV
  50.  
  51. SEGMENT MSWBLO
  52. CHARACTER*4 MOTDDL(0)
  53. ENDSEGMENT
  54.  
  55. segment lispoi
  56. INTEGER pilpoi(mpoin),pilmul(mpoin)
  57. endsegment
  58.  
  59. DIMENSION XNOR(3),U1(3),U2(3)
  60.  
  61. CHARACTER*4 CHADDL
  62. CHARACTER*8 MOTRIG
  63. CHARACTER*4 MOTPV(3), MOTBLO(5)
  64. CHARACTER*4 MODEPL(6),MODEDU(6), MOROTA(5),MORODU(5)
  65. CHARACTER*4 MODE1D(2),MOFO1D(2)
  66.  
  67. DATA EPSI / 1.D-12 /
  68. DATA MOTRIG / 'RIGIDITE' /
  69. DATA MOTPV / 'MINI','MAXI','FROT' /
  70. DATA MOTBLO / 'DEPL','ROTA','RADI','ORTH','DIRE' /
  71. DATA MODEPL / 'UX ','UY ','UZ ','UR ','UZ ','UT ' /
  72. DATA MODEDU / 'FX ','FY ','FZ ','FR ','FZ ','FT ' /
  73. DATA MOROTA / 'RX ','RY ','RZ ','RT ','RS ' /
  74. DATA MORODU / 'MX ','MY ','MZ ','MT ','MS ' /
  75. C Tableaux MODE1D et MOFO1D sont utilises pour certains modes 1D
  76. DATA MODE1D / 'UX ','UZ ' /
  77. DATA MOFO1D / 'FX ','FZ ' /
  78.  
  79. C Pour ne pas avoir de verrouillage sur MCOORD en //
  80. SEGDES,MCOORD
  81. SEGACT,MCOORD*MOD
  82.  
  83. c lecture table liaisons statiques
  84. CALL LIRTAB('LIAISONS_STATIQUES',ipt,0,iretou)
  85. c traitement table liaisons statiques
  86. IF (iretou.NE.0) THEN
  87. CALL BLOQU2(ipt)
  88. RETURN
  89. ENDIF
  90.  
  91. C Est-ce une condition unilaterale ?
  92. NILATE=0
  93. CALL LIRMOT(MOTPV,3,IPO,0)
  94. IF (IPO.EQ.1) NILATE=-1
  95. IF (IPO.EQ.2) NILATE=1
  96. IF (IPO.EQ.3) NILATE=2
  97. C Pas de frottement en 1D
  98. IF (IPO.EQ.3.AND.IDIM.EQ.1) THEN
  99. INTERR(1)=IDIM
  100. MOTERR(1:4)=MOTPV(3)
  101. CALL ERREUR(971)
  102. RETURN
  103. ENDIF
  104.  
  105. idimp1=IDIM+1
  106. C Quelques initialisations selon le type de probleme
  107. C Cas IDIM = 1 :
  108. C ISPE1D = 1 si IDIM=1 et IFOUR=9 ou 10, car les noms de DDL primaux et
  109. C variables duales ne sont pas dans l'ordre "classique" (un traitement
  110. C specifique est alors necessaire).
  111. ISPE1D=0
  112. C Deformations planes ou contraintes planes ou defo. plane gene :
  113. IF (IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3) THEN
  114. LDEPL=2
  115. IADEPL=0
  116. LROTA=1
  117. IAROTA=2
  118. C Axisymetrique :
  119. ELSE IF (IFOUR.EQ.0) THEN
  120. LDEPL=2
  121. IADEPL=3
  122. LROTA=1
  123. IAROTA=3
  124. C Fourier :
  125. ELSE IF (IFOUR.EQ.1) THEN
  126. LDEPL=3
  127. IADEPL=3
  128. LROTA=1
  129. IAROTA=3
  130. C Tridimensionnel :
  131. ELSE IF (IFOUR.EQ.2) THEN
  132. LDEPL=3
  133. IADEPL=0
  134. LROTA=3
  135. IAROTA=0
  136. C Massif 1D (IDIM=1) :
  137. ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
  138. IF (IFOUR.LE.6) THEN
  139. LDEPL=1
  140. IADEPL=0
  141. ELSE IF (IFOUR.GE.7.AND.IFOUR.LE.10) THEN
  142. LDEPL=2
  143. IADEPL=0
  144. IF (IFOUR.EQ.9.OR.IFOUR.EQ.10) ISPE1D=1
  145. ELSE IF (IFOUR.EQ.11) THEN
  146. LDEPL=3
  147. IADEPL=0
  148. ELSE IF (IFOUR.EQ.15) THEN
  149. LDEPL=2
  150. IADEPL=3
  151. ELSE
  152. LDEPL=1
  153. IADEPL=3
  154. ENDIF
  155. LROTA=0
  156. IAROTA=0
  157. C Autres cas :
  158. ELSE
  159. LDEPL=0
  160. IADEPL=0
  161. LROTA=0
  162. IAROTA=0
  163. ENDIF
  164.  
  165. C Initialisation de la liste des ddls MOTDDL (segment MSWBLO)
  166. SEGINI,MSWBLO
  167.  
  168. C-----------------------------------------------------------------------
  169. C Lecture eventuelle des MOTS autres que des DDLS
  170. C-----------------------------------------------------------------------
  171. C Lecture eventuelle de 'DEPL' et/ou 'ROTA'
  172. C --------------------
  173. IDEPL=0
  174. IROTA=0
  175. 481 CALL LIRMOT(MOTBLO,2,IMOT,0)
  176. IF (IMOT.EQ.1) IDEPL=1
  177. IF (IMOT.EQ.2) IROTA=1
  178. IF (IMOT.NE.0) GOTO 481
  179. C Lecture eventuelle de 'RADI','ORTH' ou 'DIRE'
  180. C --------------------
  181. IRADIA=0
  182. IDIREC=0
  183. IDICHP=0
  184. 4480 CALL LIRMOT(MOTBLO(3),3,IMOT,0)
  185. IF (IMOT.EQ.0) THEN
  186. IF (IDEPL.EQ.1) GOTO 44801
  187. IF (IROTA.EQ.1) GOTO 44802
  188. IBDDL=MOTDDL(/2)
  189. IF (IBDDL.NE.0) GOTO 449
  190. IF (IBDDL.EQ.0) GOTO 445
  191. ENDIF
  192. C En DIMENSION 1, les mots-cles 'RADI,'ORTH' et 'DIRE' sont interdits.
  193. IF (IDIM.EQ.1) THEN
  194. INTERR(1)=IDIM
  195. MOTERR(1:4)=MOTBLO(2+IMOT)
  196. CALL ERREUR(971)
  197. GOTO 1000
  198. ENDIF
  199. GO TO (44803,44803,44804),IMOT
  200. C Traitement des mots-cles : Mise a jour de MOTDDL
  201. C ----------------------------
  202. C On a trouve le mot DEPLAcement
  203. 44801 IDEPL=0
  204. C Cas particulier pour certains modes de IDIM=1
  205. IF (ISPE1D.EQ.1) THEN
  206. DO i=1,LDEPL
  207. MOTDDL(**)=MODE1D(IADEPL+i)
  208. MOTDDL(**)=MOFO1D(IADEPL+i)
  209. ENDDO
  210. C Cas general
  211. ELSE
  212. DO i=1,LDEPL
  213. MOTDDL(**)=MODEPL(IADEPL+i)
  214. MOTDDL(**)=MODEDU(IADEPL+i)
  215. ENDDO
  216. ENDIF
  217. GOTO 4480
  218. C On a trouve le mot ROTAtion
  219. 44802 IROTA=0
  220. DO i=1,LROTA
  221. MOTDDL(**)=MOROTA(IAROTA+i)
  222. MOTDDL(**)=MORODU(IAROTA+i)
  223. ENDDO
  224. GOTO 4480
  225. C On a trouve le mot RADial ou le mot ORTHoradial
  226. 44803 IRADIA=IMOT
  227. CALL LIROBJ('POINT',KPOINT,1,IRETOU)
  228. IF (IRETOU.EQ.0) GOTO 1000
  229. j=(KPOINT-1)*idimp1
  230. DO i=1,IDIM
  231. U1(i)=XCOOR(j+i)
  232. ENDDO
  233. IF (IDIM.EQ.3) THEN
  234. C Lecture du 2nd point de l'axe (en 3D)
  235. CALL LIROBJ('POINT',KPOINT,1,IRETOU)
  236. IF (IRETOU.EQ.0) GOTO 1000
  237. j=(KPOINT-1)*idimp1
  238. YL=0.D0
  239. DO i=1,IDIM
  240. U2(i)=XCOOR(j+i)-U1(i)
  241. YL=YL+U2(i)*U2(i)
  242. ENDDO
  243. C Calcul du vecteur directeur unitaire de l'axe (U2)
  244. IF (YL.LT.EPSI) THEN
  245. CALL ERREUR(237)
  246. GOTO 1000
  247. ENDIF
  248. YL=1.D0/SQRT(YL)
  249. DO i=1,IDIM
  250. U2(i)=U2(i)*YL
  251. ENDDO
  252. ENDIF
  253. GOTO 449
  254. C On a trouve le mot DIREction
  255. 44804 IDIREC=1
  256. CALL LIROBJ('POINT',KPOINT,0,IRETOU)
  257. IF (IRETOU.EQ.0) THEN
  258. * WRITE(IOIMP,*) 'Lecture dun chpoint'
  259. CALL LIROBJ('CHPOINT',MCHPOI,1,IRETOU)
  260. IF (IRETOU.EQ.0) GOTO 1000
  261. IDICHP=1
  262. ELSE
  263. j=(KPOINT-1)*idimp1
  264. YL=0.D0
  265. DO i=1,IDIM
  266. XNOR(i)=XCOOR(j+i)
  267. YL=YL+XNOR(i)*XNOR(i)
  268. ENDDO
  269. IF (YL.LT.EPSI) THEN
  270. CALL ERREUR(239)
  271. GOTO 1000
  272. ENDIF
  273. YL=1.D0/SQRT(YL)
  274. DO i=1,IDIM
  275. XNOR(i)=XNOR(i)*YL
  276. ENDDO
  277. ENDIF
  278. GOTO 449
  279.  
  280. C Lecture eventuelle de DDLs :
  281. C ------------------------------
  282. 445 CONTINUE
  283. C La liste des grandeurs PRIMALEs/DDLs est un LISTMOTS.
  284. C La liste des grandeurs DUALEs est un LISTMOTS obligatoire.
  285. CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETOU)
  286. IF (IERR.NE.0) GOTO 1000
  287. IF (IRETOU.EQ.0) GOTO 446
  288. CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
  289. IF (IERR.NE.0) GOTO 1000
  290. SEGACT,MLMOT1,MLMOT2
  291. IMOT1 = MLMOT1.MOTS(/2)
  292. IF (IMOT1.LE.0) THEN
  293. CALL ERREUR(643)
  294. SEGDES,MLMOT1,MLMOT2
  295. GOTO 1000
  296. ELSE IF (IMOT1.NE.MLMOT2.MOTS(/2)) THEN
  297. CALL ERREUR(854)
  298. SEGDES,MLMOT1,MLMOT2
  299. GOTO 1000
  300. ENDIF
  301. DO IMOT = 1, IMOT1
  302. MOTDDL(**)=MLMOT1.MOTS(IMOT)
  303. MOTDDL(**)=MLMOT2.MOTS(IMOT)
  304. ENDDO
  305. SEGDES,MLMOT1,MLMOT2
  306. GOTO 449
  307. C La liste des ddls autorises NOMDD est dans BDATA.ESO
  308. C On doit lire au moins 1 ddl (car sinon MOTDDL est vide !)
  309. 446 CONTINUE
  310. CALL LIRMOT(NOMDD,LNOMDD,IMOT,0)
  311. IF (IERR.NE.0) GOTO 1000
  312. IF (IMOT.NE.0) THEN
  313. MOTDDL(**)=NOMDD(IMOT)
  314. MOTDDL(**)=NOMDU(IMOT)
  315. ELSE
  316. CALL LIRCHA(CHADDL,0,IMOT)
  317. IF (IERR.NE.0) GOTO 1000
  318. IF (IMOT.EQ.0) GOTO 447
  319. MOTDDL(**)=CHADDL
  320. MOTDDL(**)=' '
  321. ENDIF
  322. GOTO 446
  323. 447 CONTINUE
  324. IBDDL=MOTDDL(/2)
  325. IPMODL = 0
  326. CALL LIROBJ('MMODEL ',IPMODL,0,IRETOU)
  327. IF (IERR.NE.0) GOTO 1000
  328. IF (IPMODL.EQ.0) THEN
  329. DO i = 2, IBDDL, 2
  330. IF (MOTDDL(i).EQ.' ') THEN
  331. MOTERR(1:4)=MOTDDL(i-1)
  332. CALL ERREUR(108)
  333. ENDIF
  334. ENDDO
  335. ELSE
  336. CALL NOVARD(IPMODL,'DEPL')
  337. CALL LIROBJ('LISTMOTS',MLMOT1,1,IRETOU)
  338. IF (IERR.NE.0) GOTO 1000
  339. CALL NOVARD(IPMODL,'FORC')
  340. CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
  341. IF (IERR.NE.0) GOTO 1000
  342. SEGACT,MLMOT1,MLMOT2
  343. IMOT1 = MLMOT1.MOTS(/2)
  344. DO i = 2, IBDDL, 2
  345. IF (MOTDDL(i).EQ.' ') THEN
  346. CALL PLACE(MLMOT1.MOTS(1),IMOT1,iplac,MOTDDL(i-1))
  347. IF (iplac.EQ.0) THEN
  348. MOTERR(1:4)=MOTDDL(i-1)
  349. CALL ERREUR(197)
  350. ELSE
  351. MOTDDL(i)=MLMOT2.MOTS(iplac)
  352. ENDIF
  353. ENDIF
  354. ENDDO
  355. SEGSUP,MLMOT1,MLMOT2
  356. ENDIF
  357. IF (IERR.NE.0) GOTO 1000
  358.  
  359. 449 IBDDL=MOTDDL(/2)
  360. C Verification que le nombre de DDLs a bloquer n'est pas nul
  361. C IF (IBDDL.EQ.0) GOTO 1000
  362. C-----------------------------------------------------------------------
  363. C Fin de la lecture des mots (DEPL,ROTA...) ou des DDLs
  364. C-----------------------------------------------------------------------
  365.  
  366. C Recherche du maillage MELEME de type POINT :
  367. C ----------------------------------------------
  368. KOBJET=0
  369. MELEME=0
  370. C On cherche d'abord si on a un POINT que l'on transformera en POI1
  371. C sinon on cherche un maillage que l'on transforme en POI1 si besoin
  372. CALL LIROBJ('POINT',KPOINT,0,IRETOU)
  373. IF (IERR.NE.0) GOTO 1000
  374. IF (IRETOU.EQ.0) THEN
  375. CALL LIROBJ('MAILLAGE',KOBJET,1,IRETOU)
  376. IF (IERR.NE.0) GOTO 1000
  377. MELEME=KOBJET
  378. SEGACT,MELEME
  379. IF (ITYPEL.NE.1) CALL CHANGE(MELEME,1)
  380. NBPOIN=NUM(/2)
  381. ELSE
  382. MELEME=KPOINT
  383. CALL CRELEM(MELEME)
  384. NBPOIN=1
  385. ENDIF
  386. *
  387. IF (IDICHP.EQ.1) THEN
  388. * Cas où la direction est donnée par un chpoint
  389. * On construit un segment MTRAV contenant les directions normées
  390. * WRITE(IOIMP,*) 'Transfo du chpoint en MTRA'
  391. * 1) Recopie des composantes et valeurs pertinentes du chpoint
  392. * dans le TMTRAV
  393. * Composantes recherchées (LMDEPL.MLMOTS)
  394. * sur les points du maillage MELEME
  395. JGN=4
  396. JGM=IDIM
  397. SEGINI,LMDEPL
  398. DO I=1,IDIM
  399. LMDEPL.MOTS(I)=MODEPL(IADEPL+I)
  400. ENDDO
  401. CALL CP2TR2(LMDEPL,MELEME,MCHPOI,MTRAV,IRET)
  402. SEGSUP LMDEPL
  403. SEGACT MELEME
  404. IF (IRET.NE.0) THEN
  405. CALL ERREUR(5)
  406. GOTO 1000
  407. ENDIF
  408. * 2) Calcul des normes
  409. * WRITE(IOIMP,*) 'Calcul des normes '
  410. SEGACT MTRAV*MOD
  411. DO IBPOIN=1,NBPOIN
  412. YL=0.D0
  413. DO I=1,IDIM
  414. XNOR(I)=BB(I,IBPOIN)
  415. YL=YL+XNOR(I)*XNOR(I)
  416. ENDDO
  417. IF (YL.LT.XPETIT) THEN
  418. CALL ERREUR(239)
  419. GOTO 1000
  420. ENDIF
  421. YL=1.D0/SQRT(YL)
  422. DO I=1,IDIM
  423. BB(I,IBPOIN)=XNOR(I)*YL
  424. ENDDO
  425. ENDDO
  426. * WRITE(IOIMP,*) 'Fin du calcul des normes '
  427. * SEGPRT,MTRAV
  428. ENDIF
  429. C Determination du nombre de multiplicateurs NNMAT par noeud de MELEME
  430. C NNMAT correspond au nombre de DDLs a bloquer par noeud = nombre de
  431. C multiplicateurs a creer par noeud (1 multiplicateur) = NRIGEL
  432. C Dans les cas RADIal et DIREction, on a une seule matrice par noeud.
  433. C Dans les autres cas, autant de matrices que MOTDDL(/2)/2.
  434. NNMAT=1
  435. IF (IDIREC+IRADIA.EQ.0) NNMAT=IBDDL/2
  436.  
  437. C Initialisation de l'objet RIGIDITE associe aux BLOCAGES
  438. NRIGE=8
  439. NRIGEL=NNMAT
  440. SEGINI,MRIGID
  441. MTYMAT=MOTRIG
  442. C* IFORIG=IFOMOD
  443. IFORIG=IFOUR
  444. ICHOLE=0
  445. IMGEO1=0
  446. IMGEO2=0
  447. KRIGI=MRIGID
  448.  
  449. C A chaque multplicateur est associe un nouveau noeud
  450. C NBPOIN : nombre de points du maillage MELEME a bloquer
  451. NBNO=XCOOR(/1)/idimp1
  452. NBNOI=NBNO
  453. NBPTS=NBNO+NNMAT*NBPOIN
  454. SEGADJ,MCOORD
  455.  
  456. C Boucle sur le nombre de DDLs a bloquer
  457. DO IAA=1,NNMAT
  458. C Pour chaque noeud du maillage, creation d'un noeud associe (place
  459. C initialement a l'origine) au IAA-eme DDL
  460. DO i=1,NBPOIN
  461. DO j=1,idimp1
  462. XCOOR(NBNOI*idimp1+j)=0.D0
  463. ENDDO
  464. NBNOI=NBNOI+1
  465. ENDDO
  466. C Creation du maillage MELEME de MULTiplicateurs associe aux BLOCAGES
  467. NBSOUS=0
  468. NBREF=0
  469. NBNN=2
  470. NBELEM=NBPOIN
  471. SEGINI,IPT1
  472. KIPT1=IPT1
  473. IPT1.ITYPEL=22
  474. DO i=1,NBPOIN
  475. j=(IAA-1)*NBPOIN+i
  476. IPT1.NUM(1,i)=NBNO+j
  477. IPT1.NUM(2,i)=NUM(1,i)
  478. IPT1.ICOLOR(i)=IDCOUL
  479. C Correction : Les pts mult sont a la meme position que les noeuds
  480. IREF3=(NUM(1,i)-1)*idimp1
  481. IREF1=(NBNO+j-1)*idimp1
  482. DO j=1,IDIM
  483. XCOOR(IREF1+j)=XCOOR(IREF3+j)
  484. ENDDO
  485. ENDDO
  486. C Creation des RAIDEURS associees au IAA-eme multplicateur (DDL)
  487. IRIGEL(1,IAA)=KIPT1
  488. IRIGEL(2,IAA)=0
  489. IRIGEL(5,IAA)=NIFOUR
  490. IRIGEL(6,IAA)=NILATE
  491. NLIGRP=2
  492. IF (IDIREC+IRADIA.NE.0) NLIGRP=1+LDEPL
  493. NLIGRD=NLIGRP
  494. C Remplissage du tableau des DESCripteurs de RIG
  495. SEGINI,DESCR
  496. IRIGEL(3,IAA)=DESCR
  497. NOELEP(1)=1
  498. NOELEP(2)=2
  499. NOELED(1)=1
  500. NOELED(2)=2
  501. IF (IDIREC+IRADIA.EQ.0) THEN
  502. j=2*(IAA-1)
  503. LISINC(1)='LX '
  504. LISINC(2)=MOTDDL(j+1)
  505. LISDUA(1)='FLX '
  506. LISDUA(2)=MOTDDL(j+2)
  507. ELSE
  508. DO i=1,LDEPL
  509. NOELEP(1+i)=2
  510. NOELED(1+i)=2
  511. IF (IROTA.NE.1) THEN
  512. LISINC(1+i)=MODEPL(IADEPL+i)
  513. LISDUA(1+i)=MODEDU(IADEPL+i)
  514. ELSE
  515. LISINC(1+i)=MOROTA(IADEPL+i)
  516. LISDUA(1+i)=MORODU(IADEPL+i)
  517. ENDIF
  518. ENDDO
  519. LISINC(1)='LX '
  520. LISDUA(1)='FLX '
  521. ENDIF
  522. SEGDES DESCR
  523.  
  524. C** NLIGRP=3
  525. C** IF (IDIREC+IRADIA.NE.0) NLIGRP=IDIM+2
  526. C** NLIGRD=NLIGRP
  527. NELRIG=NBPOIN
  528. SEGINI,XMATRI
  529. IRIGEL(4,IAA)=XMATRI
  530. COERIG(IAA)=1.D0
  531. C Remplissage de la matrice de rigidite RE :
  532. C Il faut distinguer les cas IRADIA, IDIREC et les autres
  533. C IRADIA : Il faut calculer la DIREction puis identique a IDIREC
  534. C IDIREC : La DIRECTION est stockee dans le vecteur norme XNOR
  535. C AUTRES : La matrice est predefinie dans RIG
  536. C Option RADIAL : Calcul prealable de la direction pour chaque noeud
  537. IF (IRADIA.NE.0) THEN
  538. DO IB=1,NBPOIN
  539. j=(NUM(1,IB)-1)*idimp1
  540. DO i=1,IDIM
  541. XNOR(i)=XCOOR(j+i)-U1(i)
  542. ENDDO
  543. IF (IDIM.EQ.2) THEN
  544. YL=XNOR(1)*XNOR(1)+XNOR(2)*XNOR(2)
  545. IF (YL.LT.EPSI) THEN
  546. CALL ERREUR(238)
  547. RETURN
  548. ENDIF
  549. YL=1.D0/SQRT(YL)
  550. IF (IRADIA.EQ.1) THEN
  551. XNOR(1)=XNOR(1)*YL
  552. XNOR(2)=XNOR(2)*YL
  553. ELSE IF (IRADIA.EQ.2) THEN
  554. XX=XNOR(1)
  555. XNOR(1)=-XNOR(2)*YL
  556. XNOR(2)=XX*YL
  557. ENDIF
  558. ELSE
  559. YL=XNOR(1)*U2(1)+XNOR(2)*U2(2)+XNOR(3)*U2(3)
  560. XL=0.D0
  561. DO i=1,3
  562. XNOR(i)=XNOR(i)-YL*U2(i)
  563. XL=XL+XNOR(i)*XNOR(i)
  564. ENDDO
  565. IF (XL.LT.EPSI) THEN
  566. CALL ERREUR(238)
  567. RETURN
  568. ENDIF
  569. IF (IRADIA.EQ.1) THEN
  570. XL=1.D0/SQRT(XL)
  571. XNOR(1)=XNOR(1)*XL
  572. XNOR(2)=XNOR(2)*XL
  573. XNOR(3)=XNOR(3)*XL
  574. ELSE IF (IRADIA.EQ.2) THEN
  575. XX=XNOR(1)
  576. YY=XNOR(2)
  577. ZZ=XNOR(3)
  578. XNOR(1)=YY*U2(3)-ZZ*U2(2)
  579. XNOR(2)=ZZ*U2(1)-XX*U2(3)
  580. XNOR(3)=XX*U2(2)-YY*U2(1)
  581. ENDIF
  582. ENDIF
  583. C XNOR contient la direction normee
  584. RE(1,1,IB)=0.D0
  585. RE(2,1,IB)=XNOR(1)
  586. RE(3,1,IB)=XNOR(2)
  587. RE(1,2,IB)=RE(2,1,IB)
  588. RE(1,3,IB)=RE(3,1,IB)
  589. IF (IDIM.EQ.3) THEN
  590. RE(4,1,IB)=XNOR(3)
  591. RE(1,4,IB)=RE(4,1,IB)
  592. ENDIF
  593. ENDDO
  594. C Option DIRECTION
  595. ELSE IF (IDIREC.EQ.1) THEN
  596. IF (IDICHP.EQ.1) THEN
  597. DO I=1,NBPOIN
  598. RE(1,1,i)=0.D0
  599. RE(2,1,i)=BB(1,I)
  600. RE(3,1,i)=BB(2,I)
  601. RE(1,2,i)=RE(2,1,i)
  602. RE(1,3,i)=RE(3,1,i)
  603. RE(2,3,i)=RE(3,2,i)
  604. IF (IDIM.EQ.3) THEN
  605. RE(4,1,i)=BB(3,I)
  606. RE(1,4,i)=RE(4,1,i)
  607. ENDIF
  608. ENDDO
  609. ELSE
  610. DO i=1,NBPOIN
  611. RE(1,1,i)=0.D0
  612. RE(2,1,i)=XNOR(1)
  613. RE(3,1,i)=XNOR(2)
  614. RE(1,2,i)=RE(2,1,i)
  615. RE(1,3,i)=RE(3,1,i)
  616. RE(2,3,i)=RE(3,2,i)
  617. IF (IDIM.EQ.3) THEN
  618. RE(4,1,i)=XNOR(3)
  619. RE(1,4,i)=RE(4,1,i)
  620. ENDIF
  621. * DO i=1,NBPOIN
  622. ENDDO
  623. SEGDES,xMATRI
  624. ENDIF
  625. C Autres options :
  626. ELSE
  627. DO i=1,NBPOIN
  628. RE(1,1,i)=0.D0
  629. RE(2,1,i)=1.D0
  630. RE(2,2,i)=0.D0
  631. RE(1,2,i)=RE(2,1,i)
  632. SEGDES,XMATRI
  633. * DO i=1,NBPOIN
  634. ENDDO
  635. SEGDES,xMATRI
  636. SEGDES,IPT1
  637. ENDIF
  638. SEGDES,xMATRI
  639. ENDDO
  640. C Fin de la boucle sur les IAA DDLs a bloquer
  641. IF (IDICHP.EQ.1) THEN
  642. * WRITE(IOIMP,*) 'Destruction du segment de travail'
  643. SEGSUP,MTRAV
  644. ENDIF
  645. C Fin normale du traitement
  646. SEGDES,MRIGID
  647. CALL ECROBJ('RIGIDITE',KRIGI)
  648. IF (MELEME.GT.0) THEN
  649. IF (KOBJET.EQ.0) THEN
  650. SEGSUP,MELEME
  651. ELSE
  652. IF (MELEME.EQ.KOBJET) THEN
  653. SEGDES,MELEME
  654. ELSE
  655. ** SEGSUP,MELEME
  656. SEGDES,MELEME
  657. ENDIF
  658. ENDIF
  659. ENDIF
  660. C Il peut rester des maillages actifs
  661. MRIGID=KRIGI
  662. SEGACT,MRIGID
  663. DO i=1,IRIGEL(/2)
  664. MELEME=IRIGEL(1,i)
  665. IF (MELEME.GT.0) SEGDES,MELEME
  666. ENDDO
  667. SEGDES,MRIGID
  668.  
  669. C Sortie du sousprogramme (normale ou en cas d'erreur)
  670. 1000 SEGSUP,MSWBLO
  671. SEGDES,MCOORD
  672. SEGACT,MCOORD
  673.  
  674. RETURN
  675. END
  676.  
  677.  
  678.  
  679.  
  680.  

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