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

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