Télécharger la plaquette Cast3M


fr en

Télécharger basemd.eso

Retour à la liste

Numérotation des lignes : 

basemd

  1. C BASEMD    SOURCE    PV        20/03/24    21:15:28     10554          
  2.       SUBROUTINE BASEMD
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. C
  6. C   ==================================================================
  7. C   C
  8. C   C CREATION D UNE BASE MODALE
  9. C   C SYNTAXE : B = BASE S L M U V ;
  10. C   C   B   : OBJET DE TYPE BASE MODALE
  11. C   C   S   : OBJET DE TYPE STRUCTURE
  12. C   C   L   : OBJET DE TYPE MATTAC
  13. C   C   M   : OBJET DE TYPE SOLUTION (SOUS TYPE : MODES)
  14. C   C   U   : OBJET DE TYPE SOLUTION (SOUS TYPE : SOLUTIONS STATIQUES)
  15. C   C   V   : OBJET DE TYPE SOLUTION (SOUS TYPE : PSEUMODE)
  16. C   C
  17. C   C  ECRIT PAR FARVACQUE.
  18. C   C  APPELLE LES SUBROUTINES SUIVANTS:
  19. C   C    LIRE,ECRIRE,SOLS1,ERREUR(61,130,131,133,134,135,173,226,227)
  20. C   ==================================================================
  21. C
  22. -INC SMSOLUT
  23. -INC SMBASEM
  24. -INC SMSTRUC
  25. -INC SMATTAC
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29. -INC CCHAMP
  30. -INC CCREEL
  31. -INC SMCOORD
  32. -INC SMELEME
  33.       SEGMENT ITRAV(NJONC)
  34.       SEGMENT ITRABB(0)
  35. *
  36.       PARAMETER ( LNOM1 = 2 )
  37.       CHARACTER*4 NOMOP1(LNOM1)
  38.       CHARACTER*8 CTYP
  39.       DATA NOMOP1/'PLUS','ROTA'/
  40. *
  41. *     Nouvelle version avec les TABLEs
  42. *
  43.       CALL LIRMOT(NOMOP1,LNOM1,IMOT1,0)
  44.       IF(IERR.NE.0) RETURN
  45.       CALL QUETYP(CTYP,1,IRETOU)
  46.       IF (CTYP(1:8).EQ.'TABLE   ') THEN
  47.          CALL LIRTAB('BASE_MODALE',ITBAS,1,IRETOU)
  48.          IF(IERR.NE.0) RETURN
  49.          CALL LIRTAB('POINT',ITPTS,1,IRETOU)
  50.          IF(IERR.NE.0) RETURN
  51.          IPO1 = 0
  52.          IPO2 = 0
  53.          XANG = XZERO
  54.          CALL LIROBJ('POINT   ',IPO1,1,IRETOU)
  55.          IF(IERR.NE.0) RETURN
  56.          IF (IMOT1.EQ.2) THEN
  57.             IF (IDIM.EQ.3) THEN
  58.                CALL LIROBJ('POINT   ',IPO2,1,IRETOU)
  59.                IF(IERR.NE.0) RETURN
  60.             ENDIF
  61.             CALL LIRREE(XANG,1,IRETOU)
  62.             IF(IERR.NE.0) RETURN
  63.          ENDIF
  64.          IF (IMOT1.EQ.0) THEN
  65.             CALL ERREUR(498)
  66.             RETURN
  67.          ELSE
  68.             CALL COPBAS(ITBAS,ITPTS,NOMOP1(IMOT1),IPO1,IPO2,XANG)
  69.             RETURN
  70.          ENDIF
  71.       ENDIF
  72. C
  73.       NIBST=5
  74. C
  75. C  **** LECTURE DE LA STRUCTURE
  76. C
  77.       CALL LIROBJ('STRUCTUR',ISTRU0,1,IRETOU)
  78.       IF(IERR.NE.0) GO TO 5000
  79.       MSTRUC=ISTRU0
  80.       SEGACT MSTRUC
  81.       NSTRU=LISTRU(/1)
  82.       IF(NSTRU.NE.1) THEN
  83. C        ON VERIFIE QUE LA STRUCTURE EST IDENTIQUE
  84.          MSOSTU=LISTRU(1)
  85.          SEGACT MSOSTU
  86.          I1=ISRAID
  87.          I2=ISMASS
  88.          I3=ITYSOU
  89.          SEGDES MSOSTU
  90.          DO 5 I=2,NSTRU
  91.          MSOSTU=LISTRU(I)
  92.          SEGACT MSOSTU
  93.          IF(ISRAID.NE.I1) GOTO 6
  94.          IF(ISMASS.NE.I2) GOTO 6
  95.          IF(ITYSOU.NE.I3) GOTO 6
  96.          SEGDES MSOSTU
  97.          GOTO 5
  98.  6       CONTINUE
  99.          SEGDES MSOSTU
  100.          CALL ERREUR(226)
  101. C        LES SOUS STRUCTURES NE SONT PAS IDENTIQUES
  102.          GOTO 5000
  103.  5       CONTINUE
  104.       ENDIF
  105.       SEGDES MSTRUC
  106. C
  107. C  **** LECTURE DU MATTAC
  108. C
  109.       CALL LIROBJ('ATTACHE ',IRET,0,IRETOU)
  110.       MATTAC=IRET
  111.       IF(IRETOU.EQ.0) MATTAC=0
  112. C
  113. C  **** LECTURE DES OBJETS SOLUTION
  114. C
  115.       IMODE=0
  116.       ISOLS=0
  117.       IPSMO = 0
  118.  1    CALL LIROBJ('SOLUTION',IRET,0,IRETOU)
  119.       IF(IRETOU.EQ.0) GO TO 53
  120.       MSOLUT=IRET
  121.       SEGACT MSOLUT
  122. C
  123. C  **** EST CE UN MODE ?
  124. C
  125.       IF(ITYSOL.NE.'MODE    ') GO TO 51
  126.       IF(IMODE.EQ.0) GO TO 52
  127.       MOTERR(1:8)='SOLUTION'
  128.       MOTERR(9:15)='MODE'
  129.       CALL ERREUR(130)
  130. C     MODES DEJA DONNES
  131.       SEGDES MSOLUT
  132.       GO TO 5000
  133.  52   CONTINUE
  134.       IMODE=MSOLUT
  135.       SEGACT MSOLUT
  136.       MSOLEN=MSOLIS(5)
  137.       SEGDES MSOLUT
  138.       IF(MSOLEN.NE.0) GO TO 304
  139.       MOTERR(1:8)='MODE'
  140.       CALL ERREUR(61)
  141.       GOTO 5000
  142.  304  CONTINUE
  143.       IF(ISOLS.EQ.0) GO TO 1
  144.       GO TO 53
  145.  51   CONTINUE
  146. C
  147. C  **** EST CE UN SOLSTA ?
  148. C
  149.       IF(ITYSOL.NE.'SOLUSTAT') GO TO 54
  150.       IF(ISOLS.EQ.0) GO TO 55
  151.       MOTERR(1:8)='SOLUTION'
  152.       MOTERR(9:16)='SOLUSTAT'
  153.       CALL ERREUR(130)
  154. C     SOLUTIONS STATIQUES DEJA DONNEES
  155.       SEGDES MSOLUT
  156.       GO TO 5000
  157.  55   CONTINUE
  158.       ISOLS=MSOLUT
  159.       SEGDES MSOLUT
  160.       IF(IMODE.EQ.0) GO TO 1
  161.       GO TO 53
  162. C
  163. C  **** EST CE UN PSEUMOD?
  164. C
  165.  54   CONTINUE
  166.       IF(ITYSOL.NE.'PSEUMODE') GO TO 954
  167.       IF(IPSMO.EQ.0) GO TO 955
  168.       MOTERR(1:8)='SOLUTION'
  169.       MOTERR(9:16)='PSEUMODE'
  170.       CALL ERREUR(130)
  171. C     SOLUTIONS STATIQUES DEJA DONNEES
  172.       SEGDES MSOLUT
  173.       GO TO 5000
  174.  955  CONTINUE
  175.       IPSMO=MSOLUT
  176.       SEGDES MSOLUT
  177.       IF(IMODE.EQ.0) GO TO 1
  178.       GO TO 53
  179.  954  CONTINUE
  180.       MOTERR(1:8)='SOLUTION'
  181.       MOTERR(9:16)=ITYSOL
  182.       CALL ERREUR(131)
  183. C     ON N ATTEND PAS CE SOUSTYPE DE SOLUTION
  184.       SEGDES MSOLUT
  185.       GO TO 5000
  186. C
  187. C  **** VERIFICATIONS DIVERSES
  188. C
  189.  53   CONTINUE
  190.       IF(IMODE.NE.0 . OR . MATTAC.NE.0) GO TO 60
  191.       CALL ERREUR(133)
  192. C     NI MODE NI LIAISON DANS CETTE BASE MODALE
  193.       GO TO 5000
  194.  60   CONTINUE
  195. C
  196.       SEGACT MSTRUC
  197. C   BOUCLE SUR LES SOUS-BASES
  198.       SEGINI ITRABB
  199.       DO 66 IBAS=1,NSTRU
  200.       SEGINI MSOBAS
  201.       ITRABB(**)=MSOBAS
  202.       IBSTRM(1)=LISTRU(IBAS)
  203.       IBSTRM(2)=0
  204.       IBSTRM(3)=0
  205.       IBSTRM(4)=MATTAC
  206.       IBSTRM(5)=IPSMO
  207.       IF(IBAS.EQ.1) THEN
  208.         IBSTRM(2)=IMODE
  209.       ELSE IF(IMODE.NE.0) THEN
  210. C
  211. C  **** DANS LE CAS IDEN, DUPLICATION DES MODES
  212. C
  213.         SEGACT MCOORD*mod
  214.         MSOLUT=IMODE
  215.         SEGACT MSOLUT
  216.         MELEME=MSOLIS(3)
  217.         SEGACT MELEME
  218.         NBELEM=NUM(/2)
  219.         NBREF=0
  220.         NBNN=1
  221.         NBSOUS=0
  222.         SEGINI IPT1
  223.         ITYPEL=1
  224.         MSOSTU=LISTRU(IBAS)
  225.         IPOIN=nbpts
  226.         NBPTS=IPOIN+NBELEM
  227.         SEGADJ MCOORD
  228.         DO 403 I=1,NBELEM
  229.         XCOOR(IPOIN*(IDIM+1)+1)=0.
  230.         XCOOR(IPOIN*(IDIM+1)+2)=0.
  231.         IF(IDIM.EQ.3) XCOOR(IPOIN*(IDIM+1)+3)=0.
  232.         XCOOR(IPOIN*(IDIM+1)+(IDIM+1))=0.
  233.         IPOIN=IPOIN+1
  234.         IPT1.NUM(1,I)=IPOIN
  235.  403    CONTINUE
  236.         NIPO=MSOLIS(/1)
  237.         SEGINI MSO1
  238.         MSO1.ITYSOL=ITYSOL
  239.         DO 404 I=1,NIPO
  240.         MSO1.MSOLIS(I)=MSOLIS(I)
  241.         MSO1.MSOLIT(I)=MSOLIT(I)
  242.  404    CONTINUE
  243.         MSO1.MSOLIS(3)=IPT1
  244.         SEGDES MSO1,MSOLUT,MELEME,IPT1
  245.         IBSTRM(2)=MSO1
  246.       ENDIF
  247. C
  248. C  **** BOUCLE SUR LES LIAISONS : ON CHERCHE LES LIAISONS QUI AGISSENT
  249. C  **** SUR MSOSTU.  MECA, FLUIDE ET DEPI  :MJONCT MIS DANS MSOLE1
  250. C  ****              AUTRES :RIEN
  251. C
  252.       IF(MATTAC.EQ.0) GO TO 61
  253.       N=0
  254.       SEGACT MATTAC
  255.       MSOSTU=LISTRU(IBAS)
  256.       NSOUMA=LISATT(/1)
  257.       DO 70 IA=1,NSOUMA
  258.       MSOUMA=LISATT(IA)
  259.       SEGACT MSOUMA
  260.       NL=IATREL(/1)
  261.       DO 72 IB=1,NL
  262.       MJONCT=IATREL(IB)
  263.       SEGACT MJONCT
  264.       NC=ISTRJO(/1)
  265.       DO 73 IC=1,NC
  266.       IF(ISTRJO(IC).NE.MSOSTU)   GO TO 73
  267.       IF(ITYATT.NE.'MECA'.AND.ITYATT.NE.'FLUI'.AND.ITYATT.NE.'DEPI')
  268.      & GOTO 73
  269.       N=N+1
  270.       IF(N.EQ.1)SEGINI MSOLE1
  271.       IF(N.NE.1)SEGADJ MSOLE1
  272.       MSOLE1.ISOLEN(N)=MJONCT
  273. C     WRITE(6,4446)MJONCT
  274. C4446 FORMAT('  ********MJONCT=',I6)
  275.  73   CONTINUE
  276.       SEGDES MJONCT
  277.  72   CONTINUE
  278.       SEGDES MSOUMA
  279.  70   CONTINUE
  280.       NJONC=N
  281. C
  282.       IF(ISOLS.NE.0) THEN
  283. C
  284. C  **** COMPATIBILITE ENTRE LES MJONCT ET LES SOLUTIONS STATIQUES?
  285. C
  286.         IF(NJONC.EQ.0) GOTO 900
  287. C     INCOMPATIBILITE ENTRE LES SOLSTA ET LES LIAISONS
  288.         MSOLUT=ISOLS
  289.         SEGACT MSOLUT
  290.         MSOLEN=MSOLIS(10)
  291.         SEGACT MSOLEN
  292.         LTAB=ISOLEN(/1)
  293.         IF(LTAB.LT.NJONC) THEN
  294. C     INCOMPATIBILITE ENTRE LES SOLSTA ET LES LIAISONS
  295.           SEGDES MSOLEN,MSOLUT
  296.           GO TO 900
  297.         ENDIF
  298.         IF(NJONC.LT.LTAB) SEGINI ITRAV
  299.         DO 81 J=1,NJONC
  300.         MJONCT=MSOLE1.ISOLEN(J)
  301.         DO 80 I=1,LTAB
  302.         IF(MJONCT.NE.ISOLEN(I)) GO TO 80
  303.         IF(NJONC.LT.LTAB) ITRAV(J)=I
  304.         GOTO 81
  305.  80     CONTINUE
  306. C     INCOMPATIBILITE ENTRE LES SOLSTA ET LES LIAISONS
  307.         SEGDES MSOLEN,MSOLUT
  308.         IF(NJONC.LT.LTAB) SEGSUP ITRAV
  309.         GO TO 900
  310.  81     CONTINUE
  311.         SEGDES MSOLEN,MSOLUT
  312.         IF(NJONC.LT.LTAB) THEN
  313. C
  314. C    CREATION DE L'OBJET SOLUTION STATIQUE REDUIT AUX LIAISONS DU MATTAC
  315. C
  316.           MSO1=ISOLS
  317.           SEGACT MSO1
  318.           MSOLE2=MSO1.MSOLIS(5)
  319.           SEGACT MSOLE2
  320.           N=NJONC
  321.           SEGINI MSOLEN
  322.           NBELEM=NJONC
  323.           NBNN=1
  324.           NBSOUS=0
  325.           NBREF=0
  326.           SEGINI MELEME
  327.           ITYPEL=1
  328.           DO 82 IB=1,NJONC
  329.           MJONCT=MSOLE1.ISOLEN(IB)
  330.           SEGACT MJONCT
  331.           IPT1=MJOPOI
  332.           SEGACT IPT1
  333.           NUM(1,IB)=IPT1.NUM(1,ITRAV(IB))
  334.           ISOLEN(IB)=MSOLE2.ISOLEN(ITRAV(IB))
  335.           SEGDES IPT1,MJONCT
  336.  82       CONTINUE
  337.           SEGDES MELEME,MSOLE2,MSOLEN,MSOLE1
  338.           SEGSUP ITRAV
  339.           NIPO=10
  340.           SEGINI MSOLUT
  341.       ITYSOL='SOLUSTAT'
  342.           DO 83 I=1,NIPO
  343.           MSOLIS(I)=0
  344.           MSOLIT(I)=0
  345.   83      CONTINUE
  346.           MSOLIS(3)=MELEME
  347.           MSOLIS(5)=MSOLEN
  348.           MSOLIT(5)=2
  349.           MSOLIT(10)=14
  350.           MSOLIS(10)=MSOLE1
  351.           SEGDES MSOLUT
  352.           IBSTRM(3)=MSOLUT
  353.         ELSE
  354.           IBSTRM(3)=ISOLS
  355.           SEGSUP MSOLE1
  356.         ENDIF
  357.       ELSE
  358. C
  359. C  ***  IL N'Y A PAS DE SOLUTION STATIQUES. S'IL EN FAUT ON VA LES
  360. C  ***  CALCULER EN APPELANT LE SOUS-PROGRAMME SOLS1 DE L'OPERATEUR SOLS
  361. C
  362.         IF(NJONC.NE.0) THEN
  363.            KSOSTU=MSOSTU
  364.            KSOLE1=MSOLE1
  365.            CALL SOLS1(KSOSTU,KSOLE1,KSOLUT)
  366.            IF(IERR.NE.0) THEN
  367.              SEGSUP MSOLE1
  368.              GOTO 900
  369.            ENDIF
  370.            IBSTRM(3)=KSOLUT
  371.         ENDIF
  372.       ENDIF
  373. C
  374. C  **** SI IL Y A D'AUTRES TYPES DE LIAISONS, ON CREE DES MODES ET DES
  375. C  **** SOLUTIONS STATIQUES REDUITS AUX POINTS DE CES DERNIERES LIAISONS
  376. C
  377.       IF(IMODE.EQ.0) THEN
  378. C  *** OUBLI DES MODES
  379.         CALL ERREUR(227)
  380.       ENDIF
  381.         GOTO 62
  382. C
  383.   900 CONTINUE
  384.       MOTERR(1:8)='SOLUSTAT'
  385.       MOTERR(9:15)='ATTACHE'
  386.       CALL ERREUR(135)
  387.  62   CONTINUE
  388.       SEGDES MATTAC
  389.  61   CONTINUE
  390.       SEGDES MSOBAS
  391.  66   CONTINUE
  392.       SEGDES MSTRUC
  393.       N=ITRABB(/1)
  394.       IF(N.NE.0) THEN
  395.       SEGINI MBASEM
  396.       DO 800 NN=1,N
  397.       LISBAS(NN)=ITRABB(NN)
  398. 800   CONTINUE
  399.       SEGDES MBASEM
  400.       CALL ECROBJ('BASEMODA',MBASEM)
  401.       ENDIF
  402.       SEGSUP ITRABB
  403.  5000 CONTINUE
  404.       RETURN
  405.       END
  406.  
  407.  
  408.  
  409.  
  410.  
  411.  
  412.  
  413.  

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