Télécharger la plaquette Cast3M


fr en

Télécharger kpres.eso

Retour à la liste

Numérotation des lignes : 

kpres

  1. C KPRES     SOURCE    JK148537  26/10/19    21:15:10     12674          
  2.       SUBROUTINE KPRES(IPMODL,IPCHPO,ICHA,ICONV,IFLAM,IASYM,IPRIG,IRET)
  3. C_______________________________________________________________________
  4. C
  5. C
  6. C     Entrees:
  7. C     ________
  8. C
  9. C       IPMODL  Pointeur sur un MMODEL
  10. C       IPCHPO  Pointeur sur un MCHAML ou CHPOINT de PRESSION
  11. C
  12. C       ICHA   Flag : =1 IPCHPO est un pointeur sur un MCHAML
  13. C                     =0 IPCHPO est un pointeur sur un CHPOINT
  14. C
  15. C       ICONV   Flag de conversion
  16. C       IFLAM   Flag de flambage
  17. C
  18. C     Sorties:
  19. C     ________
  20. C
  21. C       IPRIG  Pointeur sur un objet RIGIDITE
  22. C       IRET    Flag de retour
  23. C
  24. C       CODE COMBESCURE JANV 87
  25. C
  26. C       Passage aux nouveaux CHAMELEMs par P.DOWLATYARI le 5/04/91
  27. C
  28. C
  29. C_______________________________________________________________________
  30. C
  31.       IMPLICIT INTEGER(I-N)
  32.       IMPLICIT REAL*8(A-H,O-Z)
  33.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC CCHAMP
  37.  
  38. -INC SMRIGID
  39. -INC SMCHAML
  40. -INC SMELEME
  41. -INC SMCOORD
  42. -INC SMINTE
  43. -INC SMMODEL
  44. -INC SMCHPOI
  45.  
  46. -INC TMPTVAL
  47.  
  48.       SEGMENT WRK1
  49.        REAL*8 REL(LRE,LRE) ,XE(3,NBBB)
  50.       ENDSEGMENT
  51.  
  52.       SEGMENT WRK2
  53.        REAL*8 SHPWRK(6,NBNO)
  54.       ENDSEGMENT
  55. *
  56.       SEGMENT WRK3
  57.        REAL*8 WORK(LW)
  58.       ENDSEGMENT
  59. *
  60.       SEGMENT WRK4
  61.        REAL*8 BPSS(3,3) ,XEL(3,NBBB)
  62.       ENDSEGMENT
  63.       segment wrk7
  64.          real*8 propel(2),d(1),work1(1),out(1)
  65.       endsegment
  66.  
  67.       segment icpr (nbpts)
  68.  
  69.       PARAMETER ( NINF=3 )
  70.       INTEGER INFOS(NINF)
  71.       LOGICAL lsupfo,lsupdp
  72. *
  73.       IRET=1
  74.       IVAPR=0
  75. *
  76. *     CHPOINT DE PRESSION ---> CHAMELEM AUX NOEUDS
  77. *
  78.       IF(ICHA.EQ.0)THEN
  79.          CALL CHAME1(0,IPMODL,IPCHPO,' ',IPCHE0,1)
  80.          IF (IERR.NE.0) RETURN
  81.          CALL REDUAF(IPCHE0,IPMODL,IPCHE1,0,IR,KER)
  82.          IF(IR   .NE. 1) CALL ERREUR(KER)
  83.          IF(IERR .NE. 0) RETURN
  84.       ELSE
  85.          IPCHE1=IPCHPO
  86.       ENDIF
  87.       MCHEL1=IPCHE1
  88.       SEGACT,MCHEL1
  89.       NBMAIC=MCHEL1.IMACHE(/1)
  90.       IF (NBMAIC.EQ.0) THEN
  91.         SEGDES,MCHEL1
  92.         IRET=0
  93.         CALL ERREUR(472)
  94.         RETURN
  95.       ENDIF
  96. C_______________________________________________________________________
  97. C
  98. C     ACTIVATION DU MODELE
  99. C_______________________________________________________________________
  100. C
  101.       MMODEL=IPMODL
  102.       SEGACT MMODEL
  103.       NSOUS=KMODEL(/1)
  104. *
  105. * verif si element shb8 d'avoir recu un chpoint de pression
  106. *
  107.       if(icha.eq.1) then
  108.         nsous=kmodel(/1)
  109.         do io=1,nsous
  110.          imodel=kmodel(io)
  111.          segact imodel
  112.           if(nefmod.eq.260) then
  113.            call erreur(1007)
  114.            return
  115.           endif
  116.         enddo
  117.       endif
  118. C
  119. C
  120. C     INITIALISATION DU CHAPEAU DE L OBJET RIGIDITE
  121. C
  122.       NRIGE=7
  123.       NRIGEL=NSOUS
  124.       SEGINI MRIGID
  125.       IPRIG=MRIGID
  126.       ICHOLE=0
  127.       IMGEO1=0
  128.       IMGEO2=0
  129.       IFORIG=IFOUR
  130.       IF (IFLAM.NE.0) THEN
  131.        MTYMAT='MASSE'
  132.       ELSE
  133.        MTYMAT='RIGIDITE'
  134.       ENDIF
  135. C
  136.       DO 140 ISOUS=1,NSOUS
  137.         IRIGEL(4,ISOUS)=0
  138.         COERIG(ISOUS)=1.D0
  139.   140 CONTINUE
  140. C_______________________________________________________________________
  141. C
  142. C      BOUCLE SUR LES SOUS ZONES DU MAILLAGE
  143. C_______________________________________________________________________
  144. C
  145.       DO 500 ISOUS=1,NSOUS
  146. C
  147. C       TRAITEMENT DU MODELE
  148. C
  149.         IMODEL=KMODEL(ISOUS)
  150.         MELE=NEFMOD
  151.         IPMAIL=IMAMOD
  152. C_______________________________________________________________________
  153. C
  154. C  INFOS. ELEMENT FINI
  155. C_______________________________________________________________________
  156. C
  157.         LHOOK = INFELE(10)
  158.         LHOO2 = LHOOK*LHOOK
  159.         NSTRS = INFELE(16)
  160.         MFR   = INFELE(13)
  161.         LW    = INFELE(7)
  162.         IF(MELE.EQ.28)LW=600
  163.         NDDL  = INFELE(15)
  164.         LRE   = INFELE(9)
  165.         IPORE = INFELE(8)
  166.         LVAL  = (LRE*(LRE+1))/2
  167.         NHRM   = NIFOUR
  168. C
  169. C       CREATION DU TABLEAU INFOS
  170. C
  171.         INFOS(1)=0
  172.         INFOS(2)=0
  173.         INFOS(3)=NIFOUR
  174. C_______________________________________________________________________
  175. C
  176. C  INFOS. MAILLAGE
  177. C_______________________________________________________________________
  178. C
  179.         MELEME=IPMAIL
  180.         SEGACT MELEME
  181.         NBNN=NUM(/1)
  182.         NBELEM=NUM(/2)
  183. C_______________________________________________________________________
  184. C
  185. C  SEGMENTS D'INTEGRATION
  186. C_______________________________________________________________________
  187. C
  188. * Minte : 1er  segment d'integration, il existe pour tous les e.f.
  189. * Minte1: 2eme segment d'integration, uniquement pour certains e.f.
  190. *         en particulier pour Coq6 et Coq8
  191. * nbpg:nb de points de gauss = nbpgau du segment minte
  192. * iele:no d'element geometrique associe a l'e.f. mele
  193. * nbff:nb de fonctions de forme = nbno du segment minte
  194. *
  195.         NBPGAU= INFELE(  6)
  196.         IELE  = INFELE( 14)
  197.         ICARA = INFELE(  5)
  198. *        MINTE = INFELE(11)
  199.         MINTE=INFMOD(5)
  200.         MINTE1= INFMOD(3)
  201.         if(mele.ne.260)SEGACT MINTE
  202. C_______________________________________________________________________
  203. C
  204. C INITIALISATION DU SEGMENT DESCR, SEGMENT DESCRIPTEUR DES
  205. C DES INCONNUES RELATIVES A LA MATRICE DE RIGIDITE
  206. C_______________________________________________________________________
  207. C
  208.         NLIGRP = INFELE(9)
  209.         NLIGRD = INFELE(9)
  210.         SEGINI DESCR
  211.         IPDESC=DESCR
  212.         if(lnomid(1).ne.0) then
  213.           nomid=lnomid(1)
  214.           segact nomid
  215.           modepl=nomid
  216.           ndepl=lesobl(/2)
  217.           ndum=lesfac(/2)
  218.           lsupdp=.false.
  219.         else
  220.           lsupdp=.true.
  221.           CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,NDUM)
  222.         endif
  223.          if(lnomid(2).ne.0) then
  224.            nomid=lnomid(2)
  225.           segact nomid
  226.           moforc=nomid
  227.           nforc=lesobl(/2)
  228.           lsupfo=.false.
  229.         else
  230.          lsupfo=.true.
  231.          CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,NDUM)
  232.         endif
  233. *
  234.         IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
  235.           CALL ERREUR(5)
  236.           SEGSUP DESCR,MRIGID
  237.           SEGDES MCHEL1
  238.           IF(ICHA.EQ.0)CALL DTCHAM(IPCHE1)
  239.           SEGDES MMODEL,MELEME,MINTE
  240.           SEGDES IMODEL
  241.           IRET=0
  242.           RETURN
  243.         ENDIF
  244. *
  245. *       REMPLISSAGE DU SEGMENT DESCRIPTEUR
  246. *
  247.         IDDL=1
  248.         NCOMP=NDEPL
  249.         NBNNS=NBNN
  250.         NOMID=MODEPL
  251.         SEGACT NOMID
  252.         NOMID=MOFORC
  253.         SEGACT NOMID
  254.         IF (MFR.EQ.33) NCOMP=NDEPL-1
  255.         IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2
  256.         DO 1004 INOEUD=1,NBNNS
  257.           DO 1005 ICOMP=1,NCOMP
  258.             NOMID=MODEPL
  259.             LISINC(IDDL)=LESOBL(ICOMP)
  260.             NOMID=MOFORC
  261.             LISDUA(IDDL)=LESOBL(ICOMP)
  262.             NOELEP(IDDL)=INOEUD
  263.             NOELED(IDDL)=INOEUD
  264.             IDDL=IDDL+1
  265.  1005     CONTINUE
  266.  1004   CONTINUE
  267.         NOMID=MODEPL
  268.         if(lsupdp)SEGSUP NOMID
  269.         NOMID=MOFORC
  270.         if(lsupfo)SEGSUP NOMID
  271. *
  272. *          CAS DES MILIEUX POREUX
  273. *
  274. *          IF (MFR.EQ.33) THEN
  275. *            DO 1104 INOEUD=1,NBSOM(IELE)
  276. *              NOMID=MODEPL
  277. *              LISINC(IDDL)=LESOBL(NDEPL)
  278. *              NOMID=MOFORC
  279. *              LISDUA(IDDL)=LESOBL(NDEPL)
  280. *              NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  281. *              NOELED(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  282. *              IDDL=IDDL+1
  283. *1104        CONTINUE
  284. *          ENDIF
  285. *
  286. *          CAS DES ELEMENT RACCORD
  287. *
  288.         IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
  289.           CALL IDPRIM(IMODEL,MFR+1000,MODEPL,NDEPL,NDUM)
  290.           CALL IDDUAL(IMODEL,MFR+1000,MOFORC,NFORC,NDUM)
  291.           DO 1106 INOEUD=NBNNS+1,NBNN
  292.             DO 1107 ICOMP=1,NDEPL
  293.               NOMID=MODEPL
  294.               LISINC(IDDL)=LESOBL(ICOMP)
  295.               NOMID=MOFORC
  296.               LISDUA(IDDL)=LESOBL(ICOMP)
  297.               NOELEP(IDDL)=INOEUD
  298.               NOELED(IDDL)=INOEUD
  299.               IDDL=IDDL+1
  300. 1107        CONTINUE
  301. 1106      CONTINUE
  302.           NOMID=MODEPL
  303.           SEGSUP NOMID
  304.           NOMID=MOFORC
  305.           SEGSUP NOMID
  306.         ENDIF
  307.  
  308.         SEGDES DESCR
  309. C_______________________________________________________________________
  310. C
  311. C INITIALISATION DU SEGMENT IMATRI,
  312. C CONTENANT LES MATRICES DE RIGIDITE ELEMENTAIRES
  313. C_______________________________________________________________________
  314. C
  315. * NBELEM: NB D'ELEMENTS DANS LA SOUS ZONE
  316.         NELRIG = NBELEM
  317.         RIGREL=0
  318.         SEGINI xMATRI
  319. C_______________________________________________________________________
  320. C
  321. C  TRAITEMENT DU CHAPEAU DES RIGIDITES, SEGMENT MRIGID
  322. C_______________________________________________________________________
  323. C
  324.         IRIGEL(1,ISOUS)=IPMAIL
  325.         IRIGEL(2,ISOUS)=0
  326.         IRIGEL(3,ISOUS)=IPDESC
  327.         IRIGEL(4,ISOUS)=xMATRI
  328.         IRIGEL(5,ISOUS)=NIFOUR
  329.         IF (IASYM .EQ. 0) THEN
  330.           IRIGEL(7, ISOUS) = 0
  331.           xmatri.symre=0
  332.         ELSE
  333.           IRIGEL(7, ISOUS) = 2
  334.           xmatri.symre=2
  335.         ENDIF
  336. C_______________________________________________________________________
  337. C
  338. C VALEURS DE PRESSION
  339. C_______________________________________________________________________
  340. C
  341.         CALL PLACE2(MCHEL1.IMACHE,NBMAIC,IM,IPMAIL)
  342.         MCHAM1=MCHEL1.ICHAML(IM)
  343.         SEGACT MCHAM1
  344.         IVAPR=MCHAM1.IELVAL(1)
  345.         SEGDES MCHAM1
  346.         MELVAL=IVAPR
  347.         IF(IVAPR.NE.0)SEGACT MELVAL
  348. *
  349. C=======================================================================
  350. C     NUMERO DES ETIQUETTES      :
  351. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  352. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  353. C     5  CONTINUE
  354. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  355. C     44 CONTINUE
  356. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  357. C=======================================================================
  358.  
  359.       GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  360.      1      99,99,99,99,99,99,27,28,99,99,99,99,99,99,99,99,99,99,99,99,
  361.      2      41,99,99,44,99,99,99,99,49,99,99,99,99,99,99,56,99,99,99,99,
  362.      3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  363.      4      99,99,99,99,99,99,99,99,99,99,99,99,28,99,99,99,99),MELE
  364. C
  365.  
  366.       if(mele.eq.260) go to 1260
  367.       GOTO 99
  368.   27  CONTINUE
  369. C_______________________________________________________________________
  370. C
  371. C                   ELEMENT COQ3
  372. C_______________________________________________________________________
  373. C
  374.       NBBB=NBNN
  375.       SEGINI WRK1,WRK3,WRK4
  376.       DO 3027  IB=1,NBELEM
  377. C
  378. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  379. C
  380.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  381.       CALL ZERO(REL,LRE,LRE)
  382. C
  383. C     ON CHERCHE LES PRESSIONS
  384. C
  385.       PRESS=0.D0
  386.       IF(MELVAL.NE.0)THEN
  387.         IBMN=MIN(IB  ,VELCHE(/2))
  388.         DO 4027 IGAU=1,NBNN
  389.           IGMN=MIN(IGAU,VELCHE(/1))
  390.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  391.  4027   CONTINUE
  392.         PRESS=PRESS/NBNN
  393.       ENDIF
  394. C
  395. C         ON CALCULE K(P)
  396. C
  397. *      SEGINI XMATRI
  398.       CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
  399. *      SEGINI XMATRI
  400. *      IMATTT(IB)=XMATRI
  401. C
  402. C     REMPLISSAGE DE XMATRI
  403. C
  404. *      CALL REMPMC(REL,LRE,RE(1,1,ib))
  405. *      SEGDES XMATRI
  406.  3027 CONTINUE
  407.       SEGDES xMATRI
  408.       SEGSUP WRK1,WRK3,WRK4
  409.       GOTO 510
  410. C_______________________________________________________________________
  411. C
  412. C     ELEMENT DKT    POUR L INSTANT = COQ3
  413. C_______________________________________________________________________
  414. C
  415.   28  CONTINUE
  416.       NBBB=NBNN
  417.       SEGINI WRK1,WRK3,WRK4
  418.       DO 3028  IB=1,NBELEM
  419. C
  420. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  421. C
  422.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  423. C
  424.       CALL ZERO(REL,LRE,LRE)
  425. C
  426. C     ON CHERCHE LES PRESSIONS
  427. C
  428.       PRESS=0.D0
  429.       IF(MELVAL.NE.0)THEN
  430.         IBMN=MIN(IB  ,VELCHE(/2))
  431.         DO 4028 IGAU=1,NBNN
  432.           IGMN=MIN(IGAU,VELCHE(/1))
  433.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  434.  4028   CONTINUE
  435.         PRESS=PRESS/NBNN
  436.       ENDIF
  437. C
  438. C         ON CALCULE K(P)
  439. C
  440. *      SEGINI XMATRI
  441.       CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
  442. *      SEGINI XMATRI
  443. *      IMATTT(IB)=XMATRI
  444. C
  445. C     REMPLISSAGE DE XMATRI
  446. C
  447. *      CALL REMPMC(REL,LRE,RE)
  448. *      SEGDES XMATRI
  449.  3028 CONTINUE
  450.       SEGDES xMATRI
  451.       SEGSUP WRK1,WRK3,WRK4
  452.       GOTO 510
  453. C_______________________________________________________________________
  454. C
  455. C  ELEMENT COQ8  NON ENCORE BRANCHE
  456. C  LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  457. C_______________________________________________________________________
  458. C
  459.  41   CONTINUE
  460.       NBBB=NBNN
  461.       SEGINI WRK1,WRK3
  462.       DO 3041 IB=1,NBELEM
  463. C
  464. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  465. C
  466.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  467. C
  468.       CALL ZERO(REL,LRE,LRE)
  469. C
  470. C  ON CHERCHE LES PRESSION    - ON LES MET DANS WORK
  471. C
  472.       PRESS=0.D0
  473.       IF(MELVAL.NE.0)THEN
  474.         IBMN=MIN(IB  ,VELCHE(/2))
  475.         DO 4041 IGAU=1,NBNN
  476.           IGMN=MIN(IGAU,VELCHE(/1))
  477.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  478.  4041   CONTINUE
  479.         PRESS=PRESS/NBNN
  480.       ENDIF
  481. *      IE=0
  482. *       DO 7041 IGAU=1,NBNN
  483. *         IE=IE+1
  484. *         IF (MELVAL.NE.0) THEN
  485. *           IGMN=MIN(IGAU,VELCHE(/1))
  486. *           IBMN=MIN(IB  ,VELCHE(/2))
  487. *           WORK(IE)=VELCHE(IGMN,IBMN)
  488. *         ELSE
  489. *           WORK(IE)=0.D0
  490. *         ENDIF
  491. * 7041  CONTINUE
  492. C
  493. C  ON CALCULE LA RIGIDITE GEOMETRIQUE
  494. C
  495. *      SEGINI XMATRI
  496.       CALL KPCOQ8(XE,PRESS,RE(1,1,ib),IASYM)
  497. C
  498. C  REMPLISSAGE DE XMATRI
  499. C
  500. *      SEGINI XMATRI
  501. *      IMATTT(IB)=XMATRI
  502. *      CALL REMPMC(REL,LRE,RE)
  503. *      SEGDES XMATRI
  504.  3041 CONTINUE
  505.       SEGDES xMATRI
  506.       SEGSUP WRK1,WRK3
  507.       GO TO 510
  508. C_______________________________________________________________________
  509. C
  510. C     ELEMENT COQ2
  511. C_______________________________________________________________________
  512. C
  513.    44 CONTINUE
  514. *
  515. *  AM 01/09/94  PETIT TEST SUR IFOUR CAR NE FONCTIONNE
  516. *  QU'EN SERIE DE FOURIER
  517. *
  518.       IF(IFOUR.NE.1) GO TO 99
  519.  
  520. *  BP 17/02/2014 on teste aussi qu'on demande la partie symetrique seule
  521.       IF(IASYM.NE.0) THEN
  522.         write(ioimp,*) 'L option de calcul ASYMetrique ',
  523.      &  'n est pas disponible avec les coq2 !'
  524.         call ERREUR(19)
  525.         goto 9990
  526.       ENDIF
  527.  
  528.       NBBB=NBNN
  529.       SEGINI WRK1,WRK3,WRK4
  530.       DO 3044 IB=1,NBELEM
  531. C
  532. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE  L ELEMENT IB
  533. C
  534.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  535.  
  536.        IF (IFOUR.EQ.1.AND.IDIM.EQ.3) THEN
  537. c jk148537 assume 1->r 3->z 
  538.          do in=1,nbnn
  539.            xe(2,in) = xe(3,in)
  540.          enddo
  541.        ENDIF
  542.  
  543.       CALL ZERO(REL,LRE,LRE)
  544. C
  545. C     ON CHERCHE LES PRESSIONS   ON LES MET DANS WORK...
  546. C
  547.       WORK(1)=0.D0
  548.  
  549.       IF(MELVAL.NE.0)THEN
  550.         IBMN=MIN(IB  ,VELCHE(/2))
  551.         DO 1344 IGAU=1,NBNN
  552.           IGMN=MIN(IGAU,VELCHE(/1))
  553.           WORK(1)=WORK(1)+VELCHE(IGMN,IBMN)
  554.  1344   CONTINUE
  555.         WORK(1)=WORK(1)/NBNN
  556.       ENDIF
  557. C
  558. C     APPEL A COQUE2 KP
  559. C
  560.       AN=NHRM
  561.       CALL CQ2KP(XE,WORK(1),AN,WORK(2),WORK(7),WORK(12),
  562.      1 WORK(19),WORK(26),REL,POIGAU,QSIGAU,NBPGAU,WORK(29),WORK(93),
  563.      2 WORK(157),WORK(221),WORK(285))
  564. C
  565. C     REMPLISSAGE DE XMATRI
  566. C
  567. *      SEGINI XMATRI
  568. *      IMATTT(IB)=XMATRI
  569.       CALL REMPMT(REL,LRE,RE(1,1,ib))
  570. *      SEGDES XMATRI
  571.  3044 CONTINUE
  572.       SEGDES xMATRI
  573.       SEGSUP WRK1,WRK3,WRK4
  574.       GOTO 510
  575. C_______________________________________________________________________
  576. C
  577. C     ELEMENT COQ4   NON ENCORE BRANCHE
  578. C  LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  579. C_______________________________________________________________________
  580. C
  581.    49 CONTINUE
  582.       NBBB=NBNN
  583.       SEGINI WRK1,WRK3,WRK4
  584.       DO 3049 IB=1,NBELEM
  585. C
  586. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE  L ELEMENT IB
  587. C
  588.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  589. C
  590.       CALL ZERO(REL,LRE,LRE)
  591. C
  592. C     ON CHERCHE LES PRESSIONS   ON LES MET DANS WORK...
  593. C
  594.       PRESS=0.D0
  595.       IF(MELVAL.NE.0)THEN
  596.         IBMN=MIN(IB  ,VELCHE(/2))
  597.         DO 4049 IGAU=1,NBNN
  598.           IGMN=MIN(IGAU,VELCHE(/1))
  599.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  600.  4049   CONTINUE
  601.         PRESS=PRESS/NBNN
  602.       ENDIF
  603. *       IE=0
  604. *       DO 5049 IGAU=1,NBNN
  605. *         IE=IE+1
  606. *         IF (MELVAL.NE.0) THEN
  607. *           IGMN=MIN(IGAU,VELCHE(/1))
  608. *           IBMN=MIN(IB  ,VELCHE(/2))
  609. *           WORK(IE)=VELCHE(IGMN,IBMN)
  610. *         ELSE
  611. *           WORK(IE)=0.D0
  612. *         ENDIF
  613. * 5049  CONTINUE
  614. C
  615. C     APPEL A COQUE4 KSIGMA...
  616. C
  617.       AN=NHRM
  618. *      SEGINI XMATRI
  619. *      CALL KPCOQ4(XE,PRESS,REL,IASYM)
  620.       CALL KPCOQ4(XE,PRESS,RE(1,1,ib),IASYM)
  621. C
  622. C     REMPLISSAGE DE XMATRI
  623. C
  624. *      SEGINI XMATRI
  625. *      IMATTT(IB)=XMATRI
  626. *      CALL REMPMC(REL,LRE,RE)
  627. *      SEGDES XMATRI
  628.  3049 CONTINUE
  629.       SEGDES xMATRI
  630.       SEGSUP WRK1,WRK3,WRK4
  631.       GOTO 510
  632. C_______________________________________________________________________
  633. C
  634. C    element SHB8
  635. C_______________________________________________________________________
  636. C
  637.  1260 continue
  638. *
  639.       NBBB=NBNN
  640.       SEGINI WRK1,wrk7
  641. *  reperage du chpoint de pression
  642.       segini icpr
  643.       mchpoi=ipchpO
  644.       segact mchpoi
  645.       ino=0
  646.       if(ipchp(/1).ne.1) then
  647.         call erreur(19)
  648.         return
  649.       endif
  650.       msoupo=ipchp(1)
  651.       segact msoupo
  652.       if(noharm(/1).ne.1)then
  653.          call erreur(180)
  654.          return
  655.       endif
  656.       meleme=igeoc
  657.       segact meleme
  658.       do ia=1,num(/2)
  659.         ib=num(1,ia)
  660.         if(icpr(ib).eq.0) then
  661.           ino=ino+1
  662.           icpr(ib)=ino
  663.         endif
  664.       enddo
  665.       segdes meleme
  666.       mpoval=ipoval
  667.       segact mpoval
  668. * on cherche si surf interne ou externe
  669.       meleme=ipmail
  670.       if(lisref(/1).ne.2) then
  671.          call erreur (1004)
  672.          return
  673.       endif
  674.       isur=0
  675.       do icas=1,2
  676.         ipt3=lisref(icas)
  677.         segact ipt3
  678.         do ia=1,ipt3.num(/2)
  679.           do ic=1,4
  680.             ib=ipt3.num(ic,ia)
  681.             if(icpr(ib).eq.0) go to 2260
  682.           enddo
  683.         enddo
  684.         isur=icas
  685.         go to 3260
  686.  2260  continue
  687.        segdes ipt3
  688.       enddo
  689.       call erreur(286)
  690.       return
  691. 3260  continue
  692.       propel(2)=isur
  693.  
  694.       DO 4260 IB=1,NBELEM
  695. C
  696. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE  L ELEMENT IB
  697. C
  698.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  699.       CALL ZERO(REL,LRE,LRE)
  700. C
  701. C     ON CHERCHE LES PRESSIONS   ON LES MET DANS WORK...
  702. C
  703.       pre=0.d0
  704.       do ia=1,4
  705.        ibb=ipt3.num(ia,ib)
  706.        pre=pre+vpocha(icpr(ibb),1)/4
  707.       enddo
  708.       propel(1)=pre
  709.  
  710. C
  711. C     APPEL A shb8 KP
  712. C
  713.       call shb8(10,xe,D,propel,work1,rel,out)
  714. C
  715. C     REMPLISSAGE DE XMATRI
  716. C
  717. *      SEGINI XMATRI
  718. *      IMATTT(IB)=XMATRI
  719.       CALL REMPMT(REL,LRE,RE(1,1,ib))
  720. *      SEGDES XMATRI
  721.  4260 CONTINUE
  722.       SEGDES xMATRI
  723.       SEGSUP WRK1,WRK7
  724.       segsup icpr
  725.       segdes mpoval
  726.       GOTO 510
  727. C_______________________________________________________________________
  728. C
  729. C  ELEMENT COQ6  NON ENCORE BRANCHE
  730. C  LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  731. C_______________________________________________________________________
  732. C
  733.  56   CONTINUE
  734.       NBBB=NBNN
  735.       SEGINI WRK1,WRK3
  736.       DO 3056 IB=1,NBELEM
  737. C
  738. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  739. C
  740.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  741. C
  742.       CALL ZERO(REL,LRE,LRE)
  743. C
  744. C  ON CHERCHE LES PRESSION    - ON LES MET DANS WORK
  745. C
  746.       PRESS=0.D0
  747.       IF(MELVAL.NE.0)THEN
  748.         IBMN=MIN(IB  ,VELCHE(/2))
  749.         DO 4056 IGAU=1,NBNN
  750.           IGMN=MIN(IGAU,VELCHE(/1))
  751.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  752.  4056   CONTINUE
  753.         PRESS=PRESS/NBNN
  754.       ENDIF
  755. *      IE= 0
  756. *       DO 7056 IGAU=1,NBNN
  757. *         IE=IE+1
  758. *         IF (MELVAL.NE.0) THEN
  759. *           IGMN=MIN(IGAU,VELCHE(/1))
  760. *           IBMN=MIN(IB  ,VELCHE(/2))
  761. *           WORK(IE)=VELCHE(IGMN,IBMN)
  762. *         ELSE
  763. *           WORK(IE)=0.D0
  764. *         ENDIF
  765. * 7056  CONTINUE
  766. C
  767. C  ON CALCULE LA RIGIDITE GEOMETRIQUE
  768. C
  769. *      SEGINI XMATRI
  770.       CALL KPCOQ6(XE,PRESS,RE(1,1,ib),IASYM)
  771. C
  772. C  REMPLISSAGE DE XMATRI
  773. C
  774. *      SEGINI XMATRI
  775. *      IMATTT(IB)=XMATRI
  776. *      CALL REMPMC(REL,LRE,RE)
  777. *      SEGDES XMATRI
  778.  3056 CONTINUE
  779.       SEGDES xMATRI
  780.       SEGSUP WRK1,WRK3
  781.       GO TO 510
  782. C_______________________________________________________________________
  783. C
  784. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  785. C_______________________________________________________________________
  786. C
  787.   510 CONTINUE
  788.       SEGDES MELEME
  789.       SEGDES IMODEL
  790.       IF (IVAPR.NE.0) SEGDES MELVAL
  791. C
  792.       if(mele.ne.260)SEGDES MINTE
  793. C      SEGSUP INFO
  794. C_______________________________________________________________________
  795. C
  796. C      FIN DE BOUCLE SUR LES MODELES ELEMENTAIRES
  797. C_______________________________________________________________________
  798. C
  799.   500 CONTINUE
  800. C
  801.       SEGDES MRIGID
  802.       SEGDES MMODEL
  803.       SEGDES MCHEL1
  804.       IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
  805.       RETURN
  806. C
  807. C_______________________________________________________________________
  808. C
  809. C     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  810. C_______________________________________________________________________
  811. C
  812. C     ELEMENT NON IMPLEMENTE
  813. C
  814.    99 CONTINUE
  815.       MOTERR(1:4)=NOMTP(MELE)
  816.       MOTERR(5:12)='KPRES   '
  817.       CALL ERREUR(86)
  818. C
  819.  9990 CONTINUE
  820.       IRET=0
  821.  
  822.       IF(IVAPR.NE.0)SEGDES MELVAL
  823. C
  824.       SEGDES MELEME
  825.       SEGDES IMODEL
  826.       SEGSUP DESCR
  827.       SEGSUP xMATRI
  828.  
  829.       SEGDES MMODEL
  830.       SEGDES MCHEL1
  831.       IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
  832.       SEGDES MINTE
  833.       SEGSUP MRIGID
  834.  
  835.       RETURN
  836.       END
  837.  
  838.  
  839.  
  840.  
  841.  
  842.  
  843.  
  844.  

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