Sources Esope | Cast3M

manuc5
C MANUC5    SOURCE    CB215821  24/04/12    21:16:37     11897          
 
*--------------------------------------------------------------------*
*                                                                    *
*            CREATION D'UN NOUVEAU CHAMELEM PAR MANU                 *
*                                                                    *
*--------------------------------------------------------------------*
      SUBROUTINE MANUC5
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
 
-INC SMLMOTS
-INC SMLREEL
-INC SMLENTI
-INC SMELEME
-INC SMMODEL
*
      CHARACTER*(LOCOMP) MOCOMP,MOTYPE(3)
      CHARACTER*(4) MOT4
      CHARACTER*8 MOCHOY
      CHARACTER*8 CAR
      CHARACTER*16 JECONS
      CHARACTER*(LOCHAI) JEROME,CHAIN1
      CHARACTER*8 LISMOT(5),REPA(1)
      DATA MOTYPE/'TYPE','CONS','EVOL'/
      DATA REPA/'REPA'/
      DATA LISMOT/'NOEUD','GRAVITE','RIGIDITE','MASSE','STRESSES'/
*
*     Initialisation des segments
*
      IPMODL=0
      IPMAIL=0
      IPLAC =0
*
*     LECTURE D'UN MODELE
*
      CALL LIROBJ('MMODEL  ',IPMODL,0,IRET)
      IF (IRET .EQ. 1) CALL ACTOBJ('MMODEL  ',IPMODL,1)
      IF (IERR.NE.0) RETURN
      IF (IRET.EQ.0) THEN
*
*     SINON D'UN MAILLAGE
*
        MOTERR(1:8)='MAILLAGE'
        CALL MESLIR(-137)
        CALL LIROBJ('MAILLAGE',IPMAIL,0,IRET)
        IF (IERR.NE.0) RETURN
*
*     SINON lecture du mot EVOL
*
        IF (IRET.EQ.1) THEN          
          CALL ACTOBJ('MAILLAGE',IPMAIL,1)
        ELSE
          CALL LIRMOT(MOTYPE(3),1,IPLAC,0)
          IF (IERR.NE.0) RETURN
          IF (IPLAC.NE.1) THEN
            CALL ERREUR(907)
            RETURN
          ENDIF
          IF (IPLAC.EQ.1) THEN
            CALL MANUC8
            RETURN
          ENDIF
        ENDIF
      ENDIF
*
      JG=0
      JGN=LOCOMP
      JGM=0
      CALL oooprl(1)
      SEGINI,MLMOTS,MLMOT1,MLMOT2,MLMOT3,MLREE1,MLENT2
      CALL oooprl(0)
 
      L1   = 0
      LL1  = 0
      IPLAC = 0
*
      itart=0
      CALL LIRMOT(REPA,1,itart,0)
      IF (IERR.NE.0) GOTO 99
*
  10  CONTINUE
*
*        ON DESIRE LIRE UNE COMPOSANTE
*
         IRCHOI = 0
         CALL LIRCHA(CHAIN1,0,IRCHOI)
         IF (IERR.NE.0) GOTO 99
         IF (IRCHOI.EQ.0) GO TO 20
         MOCOMP=CHAIN1
         MOT4  =CHAIN1
*
*    SI ON A LU LE MOT TYPE
*
         IF (MOT4.EQ.MOTYPE(1)) THEN
           CALL LIRCHA(JEROME,1,L1)
           GOTO 10
         ENDIF
*
*    SI ON A LU LE MOT CONS
*
        IF(IPMAIL.NE.0)THEN
         IF(MOT4.EQ.MOTYPE(2)) THEN
         CALL LIRCHA(JECONS,1,LL1)
         GO TO 10
         ENDIF
        ENDIF
        IF(IPMODL.NE.0.AND.IPLAC.EQ.0)THEN
         MOCHOY=CHAIN1
         CALL PLACE(LISMOT,5,IPLAC,MOCHOY)
         IF (IPLAC.NE.0)GOTO 10
        ENDIF
*
*  SINON ON TESTE LE NOMBRE DE CARACTERES LUS
*
         IF(IRCHOI.GT.LOCOMP) THEN
            CALL ERREUR(536)
            GOTO 99
         ENDIF
 
* On recupere la valeur de la composante (REEL*8 ou POINTEURXXX)
         CALL LIRREE(RECOM,0,IRET2)
         IF (IRET2.EQ.1) THEN
            MLMOT1.MOTS(**) = MOCOMP
            JG=MLREE1.PROG(/1)+1
            SEGADJ MLREE1
            MLREE1.PROG(JG)=RECOM
 
         ELSE
            CALL QUETYP(CAR,1,IRET1)
            IF (IERR.NE.0) GO TO 99
            CALL LIROBJ(CAR,IPTRUC,0,IRET1)
            IF(IRET1 .EQ. 1) CALL ACTOBJ(CAR,IPTRUC,1)
            IF (IERR.NE.0) GO TO 99
*
*       ON A LU UN OBJET DE TYPE AUTRE QU'UN FLOTTANT
*
               MLMOT2.MOTS(**) = MOCOMP
               MLMOT3.MOTS(**) = CAR(1:4)
               MOTS(**)        = CAR(5:8)
               JG = MLENT2.LECT(/1)+1
               SEGADJ MLENT2
               MLENT2.LECT(JG)=IPTRUC
         ENDIF
      GOTO 10
*
 20   CONTINUE
 
       IPOI1 = 0
       IF ( L1.EQ.0) THEN
          JEROME=' '
          L1 = 1
       ENDIF
*
*     RECUPERATION DES ZONES ELEMENTAIRES DU MAILLAGE
*
      IF(IPMAIL.NE.0)THEN
        MELEME=IPMAIL
        JG=LISOUS(/1)
        IF (JG.EQ.0) THEN
         JG=1
         JGN=16
         JGM=JG
         CALL oooprl(1)
         SEGINI MLENT1,MLMOT4
         CALL oooprl(0)
         MLENT1.LECT(1)=IPMAIL
        ELSE
         JGN=16
         JGM=JG
         CALL oooprl(1)
         SEGINI MLENT1,MLMOT4
         CALL oooprl(0)
         DO 22 I =1,JG
           MLENT1.LECT(I)=LISOUS(I)
   22    CONTINUE
        ENDIF
*
        IF ( LL1.EQ.0) THEN
          JECONS='                '
        ENDIF
*
*     ON STOCKE LE  NOM  DU COMPOSANT
       DO 23  I=1,JG
         MLMOT4.MOTS(I)=JECONS
   23  CONTINUE
*
       CALL MANUC4(MLENT1,MLMOT1,MLMOT2,MLMOT3,MLMOTS,MLREE1,
     &            MLENT2,JEROME,L1,MLMOT4,IPOI1)
*
*     Suppression des segments
*
       SEGSUP,MLENT1
       SEGSUP,MLMOT4
 
      ELSE
       IF(IPLAC.EQ.0)IPLAC=1
       MMODEL=IPMODL
       N1 = KMODEL(/1)
       CALL MANUC6(IPMODL,MLMOT1,MLMOT2,MLMOT3,MLMOTS,MLREE1,
     &            MLENT2,JEROME,L1,IPLAC,IPOI1,itart)
      ENDIF
 
      IF (IERR.NE.0) GOTO 99
 
* Ecriture du CHAMP resultat :
      CALL ACTOBJ('MCHAML  ',IPOI1,1)
      CALL ECROBJ('MCHAML  ',IPOI1)
*
*     Suppression des segments
*
  99  CONTINUE
      SEGSUP,MLMOTS,MLMOT1,MLMOT2,MLMOT3,MLREE1,MLENT2
 
      END