Télécharger formch.eso

Retour à la liste

Numérotation des lignes :

  1. C FORMCH SOURCE CB215821 17/01/16 21:15:23 9279
  2. SUBROUTINE FORMCH(IPMODL,IPCHEL,IRET,IPT,IPCH1)
  3. C
  4. C--------------------------------------------------------------------
  5. C
  6. C REACTUALISATION DES CARACTERISTIQUES POUR CERTAINES FORMULATIONS
  7. C ROUTINE APPELE PAR FOMM
  8. C
  9. C--------------------------------------------------------------------
  10. C
  11. C ENTREES :
  12. C ---------
  13. C
  14. C IPMODL POINTEUR SUR UN MMODEL
  15. C IPCHEL POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
  16. C IPT POINTEUR SUR UN CHPOINT
  17. C
  18. C
  19. C SORTIE :
  20. C --------
  21. C
  22. C IRET 1 SI L'OPERATION EST POSSIBLE
  23. C 0 SI L'OPERATION EST IMPOSSIBLE
  24. C IPCH1 POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUES
  25. C
  26. C
  27. C PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 20 09 90
  28. C
  29. C-------------------------------------------------------------------
  30. C
  31. IMPLICIT INTEGER(I-N)
  32. IMPLICIT REAL*8(A-H,O-Z)
  33. -INC SMCHAML
  34. -INC SMCOORD
  35. -INC SMELEME
  36. -INC SMMODEL
  37. -INC CCOPTIO
  38. -INC CCHAMP
  39. C
  40. SEGMENT IWRK
  41. REAL*8 XDDL(LRE),XE(3,NBNN),WORK(LW)
  42. ENDSEGMENT
  43. C
  44. SEGMENT INFO
  45. INTEGER INFELL(JG)
  46. ENDSEGMENT
  47. *
  48. SEGMENT NOTYPE
  49. CHARACTER*16 TYPE(NBTYPE)
  50. ENDSEGMENT
  51. C
  52. SEGMENT MPTVAL
  53. INTEGER IPOS(NS) ,NSOF(NS)
  54. INTEGER IVAL(NCOSOU)
  55. CHARACTER*16 TYVAL(NCOSOU)
  56. ENDSEGMENT
  57. C
  58. CHARACTER*8 CMATE
  59. CHARACTER*(NCONCH) CONM
  60. PARAMETER ( NINF=3 )
  61. INTEGER INFOS(NINF)
  62. LOGICAL lsupdp
  63. C
  64. C
  65. DIMENSION VECT(6)
  66. *
  67. lsupdp=.TRUE.
  68. C
  69. C ON VERIFIE QUE LE MCHAML DE CARACTERISTIQUE EST SUR SON SUPPORT
  70. C
  71. CALL QUESUP (IPMODL,IPCHEL,3,1,ISUP,IRETCA)
  72. IF (ISUP.NE.0) THEN
  73. IRET=0
  74. RETURN
  75. ENDIF
  76. C
  77. C
  78. C ON COPIE LE CHAMELEM DE CARACTERISTIQUES
  79. C
  80. CALL COPIE8(IPCHEL,IPCH1)
  81. C
  82. C ON CONVERTIT LE CHAMP POINT EN CHAMP PAR ELEMENT
  83. C
  84. CALL CHAME1(0,IPMODL,IPT,' ',IPCHAM1,1)
  85. IF (IERR.NE.0) THEN
  86. CALL DTCHAM(IPCH1)
  87. IRET=0
  88. RETURN
  89. ENDIF
  90. C
  91. C ACTIVATION DU MODELE
  92. C
  93. IRET=1
  94. MMODEL=IPMODL
  95. SEGACT MMODEL
  96. NSOUS=KMODEL(/1)
  97. NSOU1=NSOUS
  98. C____________________________________________________________________
  99. C
  100. C BOUCLE SUR LES SOUS-ZONES
  101. C____________________________________________________________________
  102. C
  103. DO 200 ISOUS=1,NSOU1
  104. KERRE=0
  105. IVACAR=0
  106. IVACA1=0
  107. IVADEP=0
  108. C
  109. C ON RECUPERE L INFORMATION GENERALE
  110. C
  111. IMODEL=KMODEL(ISOUS)
  112. SEGACT IMODEL
  113. IPMAIL=IMAMOD
  114. CONM =CONMOD
  115. C
  116. C TRAITEMENT DU MODELE
  117. C
  118. MELE=NEFMOD
  119. MELEME=IMAMOD
  120. C____________________________________________________________________
  121. C
  122. C INFORMATION SUR L'ELEMENT FINI
  123. C____________________________________________________________________
  124. C
  125. CALL ELQUOI(MELE,0,6,IPINF,IMODEL)
  126. IF (IERR.NE.0) THEN
  127. SEGDES IMODEL,MMODEL
  128. CALL DTCHAM(IPCH1)
  129. CALL DTCHAM (IPCHAM1)
  130. IRET=0
  131. RETURN
  132. ENDIF
  133. C
  134. INFO=IPINF
  135. IFORM=INFELL(13)
  136. NBG =INFELL(6)
  137. ICARA=INFELL(5)
  138. LW =INFELL(7)
  139. LRE =INFELL(9)
  140. C
  141. C ACTIVATION DU MELEME
  142. C
  143. SEGACT MELEME
  144. NBNN =NUM(/1)
  145. NBELEM=NUM(/2)
  146. C
  147. C CREATION DU TABLEAU INFOS
  148. C
  149. CALL IDENT(IPMAIL,CONM,IPCH1,IPCHAM1,INFOS,IRTD)
  150. IF (IRTD.EQ.0) THEN
  151. NCARA=0
  152. NCARF=0
  153. NDEP=0
  154. MOCARA=0
  155. MODEPL=0
  156. GOTO 9990
  157. ENDIF
  158. C
  159. C RECHERCHE DES NOMS DE COMPOSANTES
  160. C
  161. IF(lnomid(1).ne.0) THEN
  162. nomid=lnomid(1)
  163. segact nomid
  164. modepl=nomid
  165. ndep=lesobl(/2)
  166. nfac=lesfac(/2)
  167. lsupdp=.false.
  168. ELSE
  169. lsupdp=.true.
  170. CALL IDPRIM(IMODEL,IFORM,MODEPL,NDEP,NFAC)
  171. ENDIF
  172. C
  173. C VERIFICATION DE LEUR PRESENCE
  174. C
  175. NBTYPE=1
  176. SEGINI NOTYPE
  177. MOTYPE=NOTYPE
  178. TYPE(1)='REAL*8'
  179. CALL KOMCHA(IPCHAM1,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP)
  180. SEGSUP NOTYPE
  181. IF (IERR.NE.0) THEN
  182. NCARA=0
  183. NCARF=0
  184. MOCARA=0
  185. GOTO 9990
  186. ENDIF
  187. C____________________________________________________________________
  188. C
  189. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  190. C____________________________________________________________________
  191. C
  192. NBROBL=0
  193. NBRFAC=0
  194. MOCARA=0
  195. NCARA=0
  196. NCARF=0
  197. NCARR=0
  198. IVECT=0
  199. *
  200. * CARACTERISTIQUES POUR LES BARRES
  201. *
  202. IF (IFORM.EQ.27) THEN
  203. NBROBL=1
  204. SEGINI NOMID
  205. MOCARA=NOMID
  206. LESOBL(1)='SECT'
  207. *
  208. NBTYPE=1
  209. SEGINI NOTYPE
  210. MOTYPE=NOTYPE
  211. TYPE(1)='REAL*8'
  212. *
  213. * CARACTERISTIQUES POUR LES POUTRES ET LES TUYAU
  214. *
  215. ELSE IF (IFORM.EQ.7.OR.IFORM.EQ.13) THEN
  216. NBRFAC=1
  217. SEGINI NOMID
  218. MOCARA=NOMID
  219. LESFAC(1)='VECT'
  220. IVECT=1
  221. *
  222. NBTYPE=1
  223. SEGINI NOTYPE
  224. MOTYPE=NOTYPE
  225. TYPE(1)='POINTEURPOINT '
  226. *
  227. * CARACTERISTIQUES POUR LES LINESPRING
  228. *
  229. ELSE IF (IFORM.EQ.15) THEN
  230. NBROBL=3
  231. SEGINI NOMID
  232. MOCARA=NOMID
  233. LESOBL(1)='VX '
  234. LESOBL(2)='VY '
  235. LESOBL(3)='VZ '
  236. *
  237. NBTYPE=1
  238. SEGINI NOTYPE
  239. MOTYPE=NOTYPE
  240. TYPE(1)='REAL*8'
  241. *
  242. * CARACTERISTIQUES POUR LES TUFI
  243. *
  244. ELSE IF (IFORM.EQ.17) THEN
  245. NBROBL=6
  246. SEGINI NOMID
  247. MOCARA=NOMID
  248. LESOBL(1)='VX '
  249. LESOBL(2)='VY '
  250. LESOBL(3)='VZ '
  251. LESOBL(4)='VXF '
  252. LESOBL(5)='VYF '
  253. LESOBL(6)='VZF '
  254. *
  255. NBTYPE=1
  256. SEGINI NOTYPE
  257. MOTYPE=NOTYPE
  258. TYPE(1)='REAL*8'
  259. *
  260. * (fdp) CARACTERISTIQUES POUR LES JOI1
  261. *
  262. ELSE IF (IFORM.EQ.75) THEN
  263. IF (IDIM.EQ.2) THEN
  264. NBROBL=2
  265. SEGINI NOMID
  266. MOCARA=NOMID
  267. LESOBL(1)='V1X '
  268. LESOBL(2)='V1Y '
  269. ENDIF
  270. IF (IDIM.EQ.3) THEN
  271. NBROBL=6
  272. SEGINI NOMID
  273. MOCARA=NOMID
  274. LESOBL(1)='V1X '
  275. LESOBL(2)='V1Y '
  276. LESOBL(3)='V1Z '
  277. LESOBL(4)='V2X '
  278. LESOBL(5)='V2Y '
  279. LESOBL(6)='V2Z '
  280. ENDIF
  281. *
  282. NBTYPE=1
  283. SEGINI NOTYPE
  284. MOTYPE=NOTYPE
  285. TYPE(1)='REAL*8'
  286. ENDIF
  287. *
  288. IF (MOCARA.NE.0) THEN
  289. *
  290. CALL KOMCHA(IPCHEL,IPMAIL,CONM,MOCARA,MOTYPE,1,
  291. & INFOS,3,IVACAR)
  292. * write (6,*) ' formch apres komcha 1 ivacar ',ivacar
  293. IF (IERR.NE.0)THEN
  294. SEGSUP NOTYPE
  295. GOTO 9990
  296. ENDIF
  297. CALL KOMCHA(IPCH1,IPMAIL,CONM,MOCARA,MOTYPE,1,
  298. & INFOS,3,IVACA1)
  299. SEGSUP NOTYPE
  300. IF (IERR.NE.0) GOTO 9990
  301. IF (IVECT.EQ.1) THEN
  302. MPTVAL=IVACAR
  303. IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN
  304. *
  305. * MOT CLE VECT EN CAS DE CONVERSION
  306. *
  307. IVECT=2
  308. NOMID=MOCARA
  309. SEGSUP NOMID
  310. NBRFAC=0
  311. NBROBL=3
  312. SEGINI NOMID
  313. MOCARA=NOMID
  314. LESOBL(1)='VX '
  315. LESOBL(2)='VY '
  316. LESOBL(3)='VZ '
  317. *
  318. NBTYPE=1
  319. SEGINI NOTYPE
  320. MOTYPE=NOTYPE
  321. TYPE(1)='REAL*8'
  322. *
  323. CALL KOMCHA(IPCHEL,IPMAIL,CONM,MOCARA,MOTYPE,1,
  324. & INFOS,3,IVACAR)
  325. * write (6,*) ' formch apres komcha 2 ivacar ',ivacar
  326. IF (IERR.NE.0)THEN
  327. SEGSUP NOTYPE
  328. GOTO 9990
  329. ENDIF
  330. CALL KOMCHA(IPCH1,IPMAIL,CONM,MOCARA,MOTYPE,1,
  331. & INFOS,3,IVACA1)
  332. SEGSUP NOTYPE
  333. IF (IERR.NE.0) GOTO 9990
  334. ENDIF
  335. ENDIF
  336. ENDIF
  337. NCARA=NBROBL
  338. NCARF=NBRFAC
  339. NCARR=NCARA+NCARF
  340. IF (MOCARA.NE.0) SEGDES NOMID
  341. *
  342. * AJUSTEMENT DE LA DIMENSION DES MELVAL
  343. *
  344. IF ((iform.EQ.7).OR.(iform.EQ.13).OR.(iform.EQ.15).OR.
  345. & (iform.EQ.17).OR.(iform.EQ.75)) THEN
  346. IF (NCARR.NE.0) THEN
  347. MPTVAL=IVACAR
  348. MELVAL=IVAL(1)
  349. C cas d'une composante non scalaire
  350. IF(IVECT.EQ.1) THEN
  351. N2EL =IELCHE(/2)
  352. IF(N2EL.LT.NBELEM) THEN
  353. N2EL = NBELEM
  354. N2PTEL= 1
  355. N1EL = 0
  356. N1PTEL= 0
  357. MPTVAL=IVACA1
  358. MELVAL=IVAL(1)
  359. SEGADJ MELVAL
  360. ENDIF
  361. C cas d'une composante scalaire
  362. ELSE
  363. N1PTEL=VELCHE(/1)
  364. N1EL =VELCHE(/2)
  365. C (fdp) correction : on remplace .LT. par .LE. pour gerer le cas ou il
  366. C n'y a qu'un seul element
  367. C (sinon plantage dans le cas d'un seul element TUFI)
  368. IF((N1EL.LE.NBELEM).OR.(N1PTEL.LE.NBG)) THEN
  369. N1EL = MAX(N1EL,NBELEM)
  370. N1PTEL= MAX(N1PTEL,NBG)
  371. N2EL = 0
  372. N2PTEL= 0
  373. IF (IFORM.EQ.7.OR.IFORM.EQ.13) N1PTEL=1
  374. MPTVAL=IVACA1
  375. DO 128 ID=1,NBROBL
  376. MELVAL=IVAL(ID)
  377. SEGADJ MELVAL
  378. 128 CONTINUE
  379. ENDIF
  380. ENDIF
  381. ENDIF
  382. ENDIF
  383. *
  384. *
  385. * MASSI COQUE COQEP POUT CIST THER TUYA LISP
  386. *
  387. C (fdp) on prevoit le cas des elements JOI1 (iform = 75)
  388. IF(iform.EQ.75) GOTO 66
  389. IF(iform.GT.38) GOTO 30
  390. GOTO (30,22,30,22,30,22,120,22,30,22,22,22,120,22,90,22,
  391. *
  392. * TUFI RCMA RCCO SULI MEMB UNIA THER INCO PORE
  393. *
  394. & 70,22,22,22,22,22,22,22,22,22,30,22,22,22,22,22,30,22,
  395. *
  396. * RACO HOMO
  397. *
  398. & 30,22,22,22),IFORM
  399. C
  400. 22 CONTINUE
  401. IRET=0
  402. MOTERR(1:8)=NOMFR(IFORM)
  403. CALL ERREUR(193)
  404. GOTO 9990
  405. C______________________________________________________________________
  406. C
  407. C FORMULATION MASSIVE - RIEN DE SPECIAL A FAIRE
  408. C FORMULATION POREUSE - RIEN DE SPECIAL A FAIRE
  409. C FORMULATIONS COQUE - ON NE FAIT RIEN
  410. C FORMULATIONS UNIAXIALE - ON NE FAIT RIEN
  411. C______________________________________________________________________
  412. C
  413. 30 CONTINUE
  414. GOTO 150
  415. C______________________________________________________________________
  416. C
  417. C FORMULATION LINESPRING
  418. C______________________________________________________________________
  419. C
  420. 90 CONTINUE
  421. IAD=2
  422. SEGINI IWRK
  423. DO 921 IB=1,NBELEM
  424. C
  425. C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS
  426. C
  427. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  428. IE=1
  429. DO 9207 IGAU=1,NBNN
  430. MPTVAL=IVADEP
  431. DO 9207 ICOMP=1,NDEP
  432. MELVAL=IVAL(ICOMP)
  433. IGMN=MIN(IGAU,VELCHE(/1))
  434. IBMN=MIN(IB ,VELCHE(/2))
  435. XDDL(IE)=VELCHE(IGMN,IBMN)
  436. IE=IE+1
  437. 9207 CONTINUE
  438. C
  439. DO 921 IC=1,NBG
  440. MPTVAL=IVACAR
  441. IF(IC.EQ.2) GO TO 948
  442. DO 923 ID=1,3
  443. MELVAL=IVAL(ID)
  444. IGMN=MIN(IC,VELCHE(/1))
  445. IBMN=MIN(IB,VELCHE(/2))
  446. VECT(ID)=VELCHE(IGMN,IBMN)
  447. 923 CONTINUE
  448. ICC=1
  449. IF(IC.GT.1) ICC=2
  450. CALL LSPFRM(IWRK,KERRE,VECT,ICC)
  451. C
  452. IF(KERRE.NE.0) THEN
  453. INTERR(1)=ISOUS
  454. INTERR(2)=IB
  455. GO TO 927
  456. ENDIF
  457. C
  458. C REMPLISSAGE
  459. C
  460. 948 CONTINUE
  461. MPTVAL=IVACA1
  462. DO 921 ID=1,3
  463. MELVAL=IVAL(ID)
  464. VELCHE(IC,IB)=VECT(ID)
  465. *
  466. 921 CONTINUE
  467. C
  468. 927 SEGSUP IWRK
  469. GOTO 151
  470. C_______________________________________________________________________
  471. C
  472. C FORMULATION TUYAU FISSURE
  473. C_______________________________________________________________________
  474. C
  475. 70 CONTINUE
  476. SEGINI IWRK
  477. DO 721 IB=1,NBELEM
  478. C
  479. C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS
  480. C
  481. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  482. IE=1
  483. DO 7207 IC=1,NBNN
  484. MPTVAL=IVADEP
  485. DO 7207 ID=1,NDEP
  486. MELVAL=IVAL(ID)
  487. IGMN=MIN(IC,VELCHE(/1))
  488. IBMN=MIN(IB,VELCHE(/2))
  489. XDDL(IE)=VELCHE(IGMN,IBMN)
  490. IE=IE+1
  491. 7207 CONTINUE
  492. C
  493. MPTVAL=IVACAR
  494. DO 723 ID=1,6
  495. MELVAL=IVAL(ID)
  496. IBMN=MIN(IB,VELCHE(/2))
  497. VECT(ID)=VELCHE(1,IBMN)
  498. 723 CONTINUE
  499. C
  500. CALL TUYFRM(IWRK,KERRE,VECT,VECT(4))
  501. C
  502. IF(KERRE.NE.0) THEN
  503. INTERR(1)=ISOUS
  504. INTERR(2)=IB
  505. GO TO 727
  506. ENDIF
  507. C
  508. C REMPLISSAGE
  509. C
  510. DO 721 IC=1,NBG
  511. MPTVAL=IVACA1
  512. DO 726 ID=1,6
  513. MELVAL=IVAL(ID)
  514. VELCHE(IC,IB)=VECT(ID)
  515. 726 CONTINUE
  516. C
  517. 721 CONTINUE
  518. C
  519. 727 SEGSUP IWRK
  520. GOTO 151
  521. C_______________________________________________________________________
  522. C
  523. C (fdp) FORMULATION JOINT 1 AVEC REPERE LOCAL LIE
  524. C_______________________________________________________________________
  525. C
  526. 66 CONTINUE
  527. SEGINI IWRK
  528. C
  529. DO IB=1,NBELEM
  530. C
  531. C ON CHERCHE LES COORDONNEES DES NOEUDS, LES DEPLACEMENTS ET
  532. C LES ROTATIONS
  533. C
  534. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  535. IE=1
  536. DO IC=1,NBNN
  537. MPTVAL=IVADEP
  538. DO ID=1,NDEP
  539. MELVAL=IVAL(ID)
  540. IGMN=MIN(IC,VELCHE(/1))
  541. IBMN=MIN(IB,VELCHE(/2))
  542. XDDL(IE)=VELCHE(IGMN,IBMN)
  543. IE=IE+1
  544. ENDDO
  545. ENDDO
  546. C
  547. C ON CHERCHE LES VECTEURS ORIENTANT L'ELEMENT JOINT DANS LE
  548. C CHAMP DE CARACTERISTIQUES
  549. C
  550. MPTVAL=IVACAR
  551. DO IC=1,NBROBL
  552. MELVAL=IVAL(IC)
  553. IBMN=MIN(IB,VELCHE(/2))
  554. VECT(IC)=VELCHE(1,IBMN)
  555. ENDDO
  556. C
  557. C ON APPLIQUE LA ROTATION AUX VECTEURS ORIENTANT LE JOINT
  558. C
  559. ITOUR=-1*INFMOD(9)
  560. IF (ITOUR.EQ.1) THEN
  561. CALL JOIFRM(IWRK,KERRE,VECT,IDIM)
  562. IF (KERRE.NE.0) THEN
  563. IF (KERRE.EQ.1) CALL ERREUR(277)
  564. ENDIF
  565. ENDIF
  566. C
  567. C REMPLISSAGE DU CHAMP DE CARACTERISTIQUES AVEC LES NOUVEAUX
  568. C VECTEURS
  569. C
  570. MPTVAL=IVACA1
  571. DO IC=1,NBROBL
  572. MELVAL=IVAL(IC)
  573. VELCHE(1,IB)=VECT(IC)
  574. ENDDO
  575. C
  576. ENDDO
  577. C
  578. 666 SEGSUP IWRK
  579. GOTO 151
  580. C_______________________________________________________________________
  581. C
  582. C FORMULATION POUTRE ET TUYAU
  583. C_______________________________________________________________________
  584. C
  585. 120 CONTINUE
  586. SEGINI IWRK
  587. C
  588. DO 121 IB=1,NBELEM
  589. C
  590. C ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS
  591. C
  592. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  593. IE=1
  594. DO 1207 IC=1,NBNN
  595. MPTVAL=IVADEP
  596. DO 1207 ID=1,NDEP
  597. MELVAL=IVAL(ID)
  598. IGMN=MIN(IC,VELCHE(/1))
  599. IBMN=MIN(IB,VELCHE(/2))
  600. XDDL(IE)=VELCHE(IGMN,IBMN)
  601. IE=IE+1
  602. 1207 CONTINUE
  603. C
  604. C CAS OU ON A LU LE MOT VECTEUR
  605. C
  606. MPTVAL=IVACAR
  607. IF (IVECT.EQ.1) THEN
  608. MELVAL=IVAL(NCARR)
  609. IBMN=MIN(IB,IELCHE(/2))
  610. IP=IELCHE(1,IBMN)
  611. IREF=(IP-1)*(IDIM+1)
  612. DO 6129 IC=1,IDIM
  613. VECT(IC)=XCOOR(IREF+IC)
  614. 6129 CONTINUE
  615. DENSIT=XCOOR(IREF+(IDIM+1))
  616. C
  617. C CAS DU CHAMELEM COMVERTI
  618. C
  619. ELSE IF (IVECT.EQ.2) THEN
  620. DO 6429 IC=1,3
  621. MELVAL=IVAL(IC)
  622. IBMN=MIN(IB,VELCHE(/2))
  623. VECT(IC)=VELCHE(1,IBMN)
  624. 6429 CONTINUE
  625. ENDIF
  626. C
  627. CALL POUFRM(IWRK,KERRE,VECT)
  628. C
  629. IF(KERRE.NE.0) THEN
  630. INTERR(1)=ISOUS
  631. INTERR(2)=IB
  632. GO TO 127
  633. ENDIF
  634. C
  635. C REMPLISSAGE
  636. C
  637. IF (IVECT.EQ.1) THEN
  638. C
  639. C ON RECREE UN VECTEUR --> MISE A JOUR DU POINTEUR IELCHE
  640. C
  641. SEGACT MCOORD
  642. C NOMBRE DE NOEUDS
  643. NBNO=XCOOR(/1)/(IDIM+1)
  644. NBNOI=NBNO
  645. NBPTS=NBNO+1
  646. SEGADJ MCOORD
  647. C
  648. C ON CREE LE NOEUD NBNO+1
  649. C
  650. XCOOR(NBNOI*(IDIM+1)+1)= VECT(1)
  651. XCOOR(NBNOI*(IDIM+1)+2)= VECT(2)
  652. IF (IDIM.EQ.3) XCOOR(NBNOI*(IDIM+1)+3)= VECT(3)
  653. XCOOR(NBNOI*(IDIM+1)+(IDIM+1))= DENSIT
  654. IPOINT = NBPTS
  655. *
  656. MPTVAL=IVACA1
  657. MELVAL=IVAL(1)
  658. SEGACT MELVAL*MOD
  659. IELCHE(1,IB)=IPOINT
  660. ELSE
  661. MPTVAL=IVACA1
  662. DO 126 ID=1,3
  663. MELVAL=IVAL(ID)
  664. VELCHE(1,IB)=VECT(ID)
  665. 126 CONTINUE
  666. ENDIF
  667. 121 CONTINUE
  668. C
  669. 127 SEGSUP IWRK
  670. GOTO 151
  671. C_______________________________________________________________________
  672. C
  673. C AUTRE FORMULATION
  674. C_______________________________________________________________________
  675. C
  676. 151 CONTINUE
  677. IF(KERRE.EQ.1) CALL ERREUR(128)
  678. IF(KERRE.EQ.2) CALL ERREUR(138)
  679. IF(KERRE.EQ.3) CALL ERREUR(277)
  680. 150 CONTINUE
  681. SEGDES MELEME
  682. SEGSUP INFO
  683. SEGDES IMODEL
  684. MPTVAL=IVACAR
  685. IF (MPTVAL.NE.0) THEN
  686. SEGACT MPTVAL
  687. DO 152 I=1,ival(/1)
  688. IF (IVAL(I).NE.0) THEN
  689. MELVAL=IVAL(I)
  690. SEGDES MELVAL
  691. ENDIF
  692. 152 CONTINUE
  693. IF (MOCARA.NE.0) SEGSUP MPTVAL
  694. ENDIF
  695. C
  696. MPTVAL=IVACA1
  697. IF (MPTVAL.NE.0) THEN
  698. SEGACT MPTVAL
  699. DO I=1,IVAL(/1)
  700. IF (IVAL(I).NE.0) THEN
  701. MELVAL=IVAL(I)
  702. SEGDES MELVAL
  703. ENDIF
  704. ENDDO
  705. IF (MOCARA.NE.0) SEGSUP MPTVAL
  706. ENDIF
  707. C
  708. MPTVAL=IVADEP
  709. IF (MPTVAL.NE.0) THEN
  710. SEGACT MPTVAL
  711. DO 153 I=1,ival(/1)
  712. IF (IVAL(I).NE.0) THEN
  713. MELVAL=IVAL(I)
  714. SEGDES MELVAL
  715. ENDIF
  716. 153 CONTINUE
  717. SEGSUP MPTVAL
  718. ENDIF
  719. C
  720. NOMID=MOCARA
  721. IF (MOCARA.NE.0) SEGSUP NOMID
  722. NOMID=MODEPL
  723. IF(lsupdp) SEGSUP NOMID
  724. C
  725. IF(KERRE.NE.0) THEN
  726. IRET=0
  727. SEGDES MMODEL
  728. CALL DTCHAM(IPCHAM1)
  729. CALL DTCHAM(IPCH1)
  730. RETURN
  731. ENDIF
  732. C
  733. 200 CONTINUE
  734. C
  735. CALL DTCHAM(IPCHAM1)
  736. SEGDES MMODEL
  737. RETURN
  738. C
  739. 9990 CONTINUE
  740. C
  741. C ERREUR DANS UNE SOUS ZONE DESACTIVATION ET RETOUR
  742. C
  743. SEGDES MELEME
  744. * SEGSUP INFO
  745. SEGDES IMODEL
  746. MPTVAL=IVACAR
  747. DO 9152 I=1,IVAL(/1)
  748. IF (IVAL(I).NE.0) THEN
  749. MELVAL=IVAL(I)
  750. SEGDES MELVAL
  751. ENDIF
  752. 9152 CONTINUE
  753. IF (MOCARA.NE.0) SEGSUP MPTVAL
  754. C
  755. MPTVAL=IVACA1
  756. DO I=1,IVAL(/1)
  757. IF (IVAL(I).NE.0) THEN
  758. MELVAL=IVAL(I)
  759. SEGDES MELVAL
  760. ENDIF
  761. ENDDO
  762. IF (MOCARA.NE.0) SEGSUP MPTVAL
  763. C
  764. MPTVAL=IVADEP
  765. DO 9153 I=1,IVAL(/1)
  766. IF (IVAL(I).NE.0) THEN
  767. MELVAL=IVAL(I)
  768. SEGDES MELVAL
  769. ENDIF
  770. 9153 CONTINUE
  771. IF (MODEPL.NE.0) SEGSUP MPTVAL
  772. C
  773. NOMID=MOCARA
  774. IF (MOCARA.NE.0) SEGSUP NOMID
  775. NOMID=MODEPL
  776. IF (MODEPL.NE.0.AND.lsupdp) SEGSUP NOMID
  777. C
  778. RETURN
  779. END
  780.  
  781.  
  782.  
  783.  
  784.  

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