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

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