Télécharger la plaquette Cast3M


fr en

Télécharger manuc5.eso

Retour à la liste

Numérotation des lignes : 

manuc5

  1. C MANUC5    SOURCE    OF166741  26/05/21    21:15:09     12556          
  2.  
  3. *--------------------------------------------------------------------*
  4. *                                                                    *
  5. *            CREATION D'UN NOUVEAU CHAMELEM PAR MANU                 *
  6. *                                                                    *
  7. *--------------------------------------------------------------------*
  8.       SUBROUTINE MANUC5
  9.  
  10.       IMPLICIT INTEGER(I-N)
  11.       IMPLICIT REAL*8(A-H,O-Z)
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15.  
  16. -INC SMLMOTS
  17. -INC SMLREEL
  18. -INC SMLENTI
  19. -INC SMELEME
  20. -INC SMMODEL
  21.  
  22.       CHARACTER*(LOCOMP) MOCOMP
  23.       CHARACTER*4 MOT4
  24.       CHARACTER*8 MOCHOY
  25.       CHARACTER*8 CAR
  26.       CHARACTER*16 JECONS
  27.       CHARACTER*(LOCHAI) JEROME,CHAIN1
  28.  
  29.       CHARACTER*4 MOTYPE(3),REPA(1)
  30.       CHARACTER*8 LISMOT(5)
  31.  
  32.       DATA MOTYPE/'TYPE','CONS','EVOL'/
  33.       DATA REPA  /'REPA'/
  34.       DATA LISMOT/'NOEUD   ','GRAVITE ','RIGIDITE',
  35.      &            'MASSE   ','STRESSES'/
  36. *
  37. *     Initialisation des segments
  38. *
  39.       IPMODL = 0
  40.       IPMAIL = 0
  41.       IPLAC  = 0
  42. *
  43. *     LECTURE D'UN MODELE
  44. *
  45.       CALL LIROBJ('MMODEL  ',IPMODL,0,IRET)
  46.       IF (IERR.NE.0) RETURN
  47.       IF (IRET .EQ. 1) THEN
  48.         CALL ACTOBJ('MMODEL  ',IPMODL,1)
  49.         IF (IERR.NE.0) RETURN
  50. *
  51. *     SINON D'UN MAILLAGE
  52. *
  53.       ELSE
  54.         MOTERR(1:8)='MAILLAGE'
  55.         CALL MESLIR(-137)
  56.         CALL LIROBJ('MAILLAGE',IPMAIL,0,IRET)
  57.         IF (IERR.NE.0) RETURN
  58.  
  59.         IF (IRET.EQ.1) THEN          
  60.           CALL ACTOBJ('MAILLAGE',IPMAIL,1)
  61.           IF (IERR.NE.0) RETURN
  62. *
  63. *     SINON lecture du mot EVOL
  64. *
  65.         ELSE
  66.           CALL LIRMOT(MOTYPE(3),1,IPLAC,0)
  67.           IF (IERR.NE.0) RETURN
  68.           IF (IPLAC.NE.1) THEN
  69.             CALL ERREUR(907)
  70.             RETURN
  71.           ENDIF
  72.           CALL MANUC8
  73.           RETURN
  74.         ENDIF
  75.       ENDIF
  76.  
  77.       JG  = 0
  78.       JGN = LOCOMP
  79.       JGM = 0
  80.       CALL oooprl(1)
  81.       SEGINI,MLMOTS,MLMOT1,MLMOT2,MLMOT3,MLREE1,MLENT2
  82.       CALL oooprl(0)
  83.  
  84.       L1   = 0
  85.       JEROME = '        '
  86.       LL1  = 0
  87.       JECONS = '        '
  88.       IPLAC = 0
  89.       itart = 0
  90.  
  91.       ISYNT2 = 0
  92.  
  93. * Syntaxe 2 : MLMOTS_Composante MLREEL_Valeur
  94.       CALL LIROBJ('LISTMOTS',MLMOT4,0,ISYNT2)
  95.       IF (IERR.NE.0) GOTO 99
  96.  
  97.       IF (ISYNT2.NE.0) THEN
  98.  
  99.         CALL LIROBJ('LISTREEL',MLREEL,1,iret)
  100.         IF (IERR.NE.0) GOTO 99
  101.  
  102.         SEGACT,MLMOT4,MLREEL
  103.         NC = MLMOT4.MOTS(/2)
  104.         NR = MLREEL.PROG(/1)
  105.         JGM = NC
  106.         JGN = LOCOMP
  107.         JG  = NC
  108.         SEGADJ,MLMOT1,MLREE1
  109.         DO I = 1, NC
  110.           MLMOT1.MOTS(I) = MLMOT4.MOTS(I)
  111.         ENDDO
  112.         IF (NR.GE.NC) THEN
  113.           DO I = 1, NC
  114.             MLREE1.PROG(I) = MLREEL.PROG(I)
  115.           ENDDO
  116.         ELSE
  117.           DO I = 1, NR
  118.             MLREE1.PROG(I) = MLREEL.PROG(I)
  119.           ENDDO
  120.           DO I = NR+1, NC
  121.             MLREE1.PROG(I) = 0.D0
  122.           ENDDO
  123.         ENDIF
  124.         SEGDES,MLMOT4,MLREEL
  125. c* Test si NC = 0 ? NR = 0 ?
  126.  
  127.       ELSE
  128. * Syntaxe 1 : Recherche du mot-cle 'REPA'
  129. c* dans le CAS OU MODELE EST FOURNI
  130. c*        IF (IPMODL.NE.0) THEN
  131.         CALL LIRMOT(REPA,1,itart,0)
  132.         IF (IERR.NE.0) GOTO 99
  133. c*        ENDIF
  134.       ENDIF
  135. *
  136.   10  CONTINUE
  137.  
  138.         IRCHOI = 0
  139.         CHAIN1 = ' '
  140.         CALL LIRCHA(CHAIN1,0,IRCHOI)
  141.         IF (IERR.NE.0) GOTO 99
  142.         IF (IRCHOI.EQ.0) GO TO 20
  143.         MOT4  = CHAIN1
  144. *
  145. *    SI ON A LU LE MOT TYPE
  146. *
  147.         IF (MOT4.EQ.MOTYPE(1)) THEN
  148.           CALL LIRCHA(JEROME,1,L1)
  149.           IF (IERR.NE.0) GOTO 99
  150.           GOTO 10
  151.         ENDIF
  152. *
  153. *    SI ON A LU LE MOT CONS (CAS OU MAILLAGE EST FOURNI)
  154. *
  155.         IF (IPMAIL.NE.0) THEN
  156.          IF (MOT4.EQ.MOTYPE(2)) THEN
  157.            CALL LIRCHA(JECONS,1,LL1)
  158.            IF (IERR.NE.0) GOTO 99
  159.            GO TO 10
  160.           ENDIF
  161.         ENDIF
  162.  
  163. *    SI ON A LU LE SUPPORT DU CHAMP (CAS OU MODELE EST FOURNI)
  164.         IF (IPMODL.NE.0.AND.IPLAC.EQ.0) THEN
  165.           MOCHOY = CHAIN1
  166.           CALL PLACE(LISMOT,5,IPLAC,MOCHOY)
  167.           IF (IPLAC.NE.0) GOTO 10
  168.         ENDIF
  169.  
  170.         IF (ISYNT2.NE.0) GOTO 10
  171.  
  172. * Syntaxe 1 : On lit paire MOT_Composante VALEUR_Flottant/Objet
  173.  
  174. *   ON A LU UNE COMPOSANTE
  175. *   ON TESTE LE NOMBRE DE CARACTERES LUS
  176.         IF (IRCHOI.GT.LOCOMP) THEN
  177.           CALL ERREUR(536)
  178.           GOTO 99
  179.         ENDIF
  180.         MOCOMP=CHAIN1
  181.  
  182. * On recupere la valeur de la composante (REEL*8 ou POINTEURXXX)
  183.         CALL LIRREE(RECOM,0,IRET2)
  184.         IF (IERR.NE.0) GO TO 99
  185.         IF (IRET2.EQ.1) THEN
  186.           MLMOT1.MOTS(**) = MOCOMP
  187.           JG=MLREE1.PROG(/1)+1
  188.           SEGADJ MLREE1
  189.           MLREE1.PROG(JG)=RECOM
  190.  
  191.         ELSE
  192.           CALL QUETYP(CAR,1,IRET1)
  193.           IF (IERR.NE.0) GO TO 99
  194.           CALL LIROBJ(CAR,IPTRUC,1,IRET1)
  195.           IF (IERR.NE.0) GO TO 99
  196.           CALL ACTOBJ(CAR,IPTRUC,1)
  197.           IF (IERR.NE.0) GO TO 99
  198. *
  199. *       ON A LU UN OBJET DE TYPE AUTRE QU'UN FLOTTANT
  200. *
  201.           MLMOT2.MOTS(**) = MOCOMP
  202.           MLMOT3.MOTS(**) = CAR(1:4)
  203.           MLMOTS.MOTS(**) = CAR(5:8)
  204.           JG = MLENT2.LECT(/1)+1
  205.           SEGADJ,MLENT2
  206.           MLENT2.LECT(JG)=IPTRUC
  207.         ENDIF
  208.       GOTO 10
  209. *
  210.  20   CONTINUE
  211.  
  212.       IPOI1 = 0
  213.       IF (L1.EQ.0) L1 = 1
  214. * Par defaut : support 'NOEUD'
  215.       IF (IPLAC.EQ.0) IPLAC=1
  216. *
  217. *     RECUPERATION DES ZONES ELEMENTAIRES DU MAILLAGE
  218. *
  219.       IF (IPMAIL.NE.0)THEN
  220.         MELEME=IPMAIL
  221.         JG=LISOUS(/1)
  222.         IF (JG.EQ.0) THEN
  223.           JG=1
  224.           JGN=16
  225.           JGM=JG
  226.           CALL oooprl(1)
  227.           SEGINI,MLENT1,MLMOT4
  228.           CALL oooprl(0)
  229.           MLENT1.LECT(1)=IPMAIL
  230.           MLMOT4.MOTS(1)=JECONS
  231.         ELSE
  232.           JGN=16
  233.           JGM=JG
  234.           CALL oooprl(1)
  235.           SEGINI,MLENT1,MLMOT4
  236.           CALL oooprl(0)
  237.           DO 22 I = 1, JG
  238.             MLENT1.LECT(I)=LISOUS(I)
  239.             MLMOT4.MOTS(I)=JECONS
  240.    22     CONTINUE
  241.         ENDIF
  242.  
  243.         CALL MANUC4(MLENT1,MLMOT1,MLMOT2,MLMOT3,MLMOTS,MLREE1,
  244.      &              MLENT2,JEROME,L1,MLMOT4,IPOI1)
  245.  
  246. *     Suppression des segments
  247.         SEGSUP,MLENT1,MLMOT4
  248.  
  249.       ELSE
  250.         CALL MANUC6(IPMODL,MLMOT1,MLMOT2,MLMOT3,MLMOTS,MLREE1,
  251.      &              MLENT2,JEROME,L1,IPLAC,IPOI1,itart)
  252.       ENDIF
  253.  
  254.       IF (IERR.NE.0) GOTO 99
  255.  
  256. * Ecriture du CHAMP resultat :
  257.       CALL ACTOBJ('MCHAML  ',IPOI1,1)
  258.       CALL ECROBJ('MCHAML  ',IPOI1)
  259. *
  260. *     Suppression des segments
  261. *
  262.   99  CONTINUE
  263.       SEGSUP,MLMOTS,MLMOT1,MLMOT2,MLMOT3,MLREE1,MLENT2
  264.  
  265.       END
  266.  
  267.  
  268.  

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