Télécharger borner.eso

Retour à la liste

borner
C BORNER    SOURCE    CB215821  21/03/03    21:15:01     10910          
 
************************************************************************
*                                                                      *
*                    OPERATEUR BORN(ER)                                *
*                                                                      *
************************************************************************
 
      SUBROUTINE BORNER
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMLMOTS
-INC SMLENTI
-INC SMLREEL
-INC SMCHPOI
-INC SMCHAML
 
      PARAMETER (NMOT = 3)
      CHARACTER*(4) LMOT(NMOT)
      CHARACTER*(LOCOMP) MOTC
 
      DATA LMOT / 'MAXI','MINI','COMP' /
 
      IPOBJ = 0
      ITOBJ = 0
 
* ===
*  1 - Lecture de l'objet a borner
* ===
* LISTENTI
 1    CONTINUE
      CALL LIROBJ('LISTENTI',IPOBJ,0,IRETOU)
      IF (IERR.NE.0) RETURN
      IF (IRETOU.EQ.0) GOTO 2
      MLENTI=IPOBJ
      SEGACT,MLENTI
      ITOBJ = 1
      GOTO 100
* LISTREEL
 2    CONTINUE
      CALL LIROBJ('LISTREEL',IPOBJ,0,IRETOU)
      IF (IERR.NE.0) RETURN
      IF (IRETOU.EQ.0) GOTO 3
      MLREEL=IPOBJ
      SEGACT,MLREEL
      ITOBJ = 2
      GOTO 100
* EVOLUTION
 3    CONTINUE
      CALL LIROBJ('EVOLUTIO',IPOBJ,0,IRETOU)
      IF (IERR.NE.0) RETURN
      IF (IRETOU.EQ.0) GOTO 4
      CALL ACTOBJ('EVOLUTIO',IPOBJ,1)
      ITOBJ = 3
      GOTO 100
* CHPOINT
 4    CONTINUE
      CALL LIROBJ('CHPOINT ',IPOBJ,0,IRETOU)
      IF (IERR.NE.0) RETURN
      IF (IRETOU.EQ.0) GOTO 5
      CALL ACTOBJ('CHPOINT ',IPOBJ,1)
      CALL NBCOMP(IPOBJ,'CHPOINT ',NBCO)
      IF(NBCO .EQ. 0)THEN
C       Pour l'instant erreur pour les objets vides
        MOTERR='CHPOINT'
        INTERR= IPOBJ
        CALL ERREUR(356)
        RETURN
      ENDIF
      ITOBJ = 4
      GOTO 100
* MCHAML
 5    CONTINUE
      CALL LIROBJ('MCHAML  ',IPOBJ,0,IRETOU)
      IF (IERR.NE.0) RETURN
      IF (IRETOU.EQ.0) GOTO 6
      CALL ACTOBJ('MCHAML  ',IPOBJ,1)
      CALL NBCOMP(IPOBJ,'MCHAML  ',NBCO)
      IF(NBCO .EQ. 0)THEN
C       Pour l'instant erreur pour les objets vides
        MOTERR='MCHAML'
        INTERR= IPOBJ
        CALL ERREUR(356)
        RETURN
      ENDIF
      ITOBJ = 5
      GOTO 100
* TYPE NON RECONNU ACTUELLEMENT
 6    CONTINUE
      CALL QUETYP(MOTERR(1:8),0,IRETOU)
      IF (IRETOU.EQ.0) THEN
        CALL ERREUR(533)
      ELSE
        CALL ERREUR(39)
      ENDIF
      RETURN
C*    GOTO 100
 
* ===
*  2 - Lecture de l'operation a realiser et la(les) borne(s) associee(s)
* ===
 100  CONTINUE
* Quelques initialisations
      IF (ITOBJ.EQ.3 .OR. ITOBJ.EQ.4 .OR. ITOBJ.EQ.5) THEN
        IF (ITOBJ.EQ.3) THEN
          JG = 10
          SEGINI,MLENTI
C*      ELSEIF(ITOBJ.EQ.4 .OR. ITOBJ.EQ.5) THEN
        ELSE
C         Cas des CHPOINTS et MCHAMLS
          JGN = LOCOMP
          JG  = NBCO
          JGM = JG
          SEGINI,MLMOTS
        ENDIF
        SEGINI,MLENT1,MLREE1,MLREE2
      ENDIF
*
      ICOMP  = 0
      ILCOND = 1
 110  CONTINUE
      IF (ITOBJ.EQ.3) THEN
        CALL LIRENT(I1,ILCOND,IRETOU)
        IF (IERR.NE.0) GOTO 900
        IF (IRETOU.EQ.0) GOTO 200
        ICOMP = ICOMP + 1
        IF (ICOMP.GT.JG) THEN
          JG = JG + 10
          SEGADJ,MLENTI,MLENT1
          SEGADJ,MLREE1,MLREE2
        ENDIF
        LECT(ICOMP) = I1
 
      ELSEIF(ITOBJ.EQ.4 .OR. ITOBJ.EQ.5) THEN
C       Cas des CHPOINTS et MCHAMLS
 
C       Lecture optionnelle du nom de la composante
        CALL LIRCHA(MOTC,0,IRETOU)
        IF (IERR  .NE.0) GOTO 900
 
        IF (IRETOU.EQ.0) THEN
C         On n'a plus rien a lire normalement on va faire le travail
          GOTO 200
        ELSE
          CALL PLACE(LMOT,NMOT,IMOT,MOTC(1:4))
          IF(IMOT .NE. 0)THEN
C           On n'a pas lu de nom de composante mais le mot cle suivant ==> REFUS
            CALL REFUS
            IF (NBCO .EQ. 1)THEN
C             On prend la seule composante du CHAMP sans poser de question
              IF     (ITOBJ.EQ.4)THEN
C               Cas des CHPOINTS
                MCHPOI=IPOBJ
                MSOUPO=MCHPOI.IPCHP(1)
                MOTC  =MSOUPO.NOCOMP(1)
              ELSEIF(ITOBJ.EQ.5)THEN
C               Cas des MCHAMLS
                MCHELM=IPOBJ
                MCHAML=MCHELM.ICHAML(1)
                MOTC  =MCHAML.NOMCHE(1)
              ELSE
                CALL ERREUR(5)
              ENDIF
            ELSE
C             On demande quelle composante==> ERREUR
              INTERR(1)=NBCO
              CALL ERREUR(761)
              RETURN
            ENDIF
          ENDIF
        ENDIF
 
        ICOMP = ICOMP + 1
        IF (ICOMP.GT.NBCO) THEN
          IF     (ITOBJ.EQ.4)THEN
C           Cas des CHPOINTS
            MOTERR='CHPOINT'
          ELSEIF(ITOBJ.EQ.5)THEN
C           Cas des MCHAMLS
            MOTERR='MCHAML'
          ELSE
            CALL ERREUR(5)
          ENDIF
          CALL ERREUR(980)
          RETURN
        ENDIF
        MOTS(ICOMP) = MOTC
      ENDIF
 
      CALL LIRMOT(LMOT,NMOT,IMOT,1)
      IF (IERR.NE.0) GOTO 900
 
      IF (ITOBJ.EQ.1) THEN
        IMIN = 0
        IMAX = 0
        CALL LIRENT(I1,1,IRETOU)
        IF (IERR.NE.0) GOTO 900
        IF (IMOT.EQ.1) THEN
          IMAX = I1
        ELSEIF(IMOT.EQ.2) THEN
          IMIN = I1
        ELSEIF(IMOT.EQ.3) THEN
          IMIN = I1
          CALL LIRENT(IMAX,1,IRETOU)
          IF (IERR.NE.0) GOTO 900
          IF (IMAX.LT.IMIN) THEN
            IMIN = IMAX
            IMAX = I1
          ENDIF
        ELSE
          CALL ERREUR(5)
        ENDIF
 
      ELSE
        XMIN = 0.
        XMAX = 0.
        CALL LIRREE(X1,1,IRETOU)
        IF (IERR.NE.0) GOTO 900
        IF (IMOT.EQ.1) THEN
          XMAX = X1
        ELSEIF(IMOT.EQ.2) THEN
          XMIN = X1
        ELSEIF(IMOT.EQ.3) THEN
          XMIN = X1
          CALL LIRREE(XMAX,1,IRETOU)
          IF (IERR.NE.0) GOTO 900
          IF (XMAX.LT.XMIN) THEN
            XMIN = XMAX
            XMAX = X1
          ENDIF
        ELSE
          CALL ERREUR(5)
        ENDIF
      ENDIF
 
      IF (ITOBJ.EQ.3 .OR. ITOBJ.EQ.4 .OR. ITOBJ.EQ.5) THEN
        MLENT1.LECT(ICOMP) = IMOT
        MLREE1.PROG(ICOMP) = XMIN
        MLREE2.PROG(ICOMP) = XMAX
        ILCOND = 0
        GOTO 110
      ENDIF
 
* ===
*  3 - Realisation des operations demandees
* ===
 200  CONTINUE
      IPRES = 0
 
      IF (ITOBJ.EQ.3 .OR. ITOBJ.EQ.4 .OR. ITOBJ.EQ.5) THEN
        IF (ICOMP.NE.JG) THEN
          JG = ICOMP
          SEGADJ,MLENT1
          SEGADJ,MLREE1,MLREE2
          IF (ITOBJ.EQ.3) THEN
            SEGADJ,MLENTI
          ELSEIF(ITOBJ.EQ.4 .OR. ITOBJ.EQ.5) THEN
            JGM = JG
            SEGADJ,MLMOTS
          ELSE
            CALL ERREUR(5)
          ENDIF
        ENDIF
      ENDIF
 
      IF      (ITOBJ .EQ. 1) THEN
        CALL BORNE1(IPOBJ,IMOT,IMIN,IMAX,IPRES)
        IF (IPRES.NE.0) CALL ECROBJ('LISTENTI',IPRES)
 
      ELSEIF(ITOBJ .EQ. 2) THEN
        CALL BORNE2(IPOBJ,IMOT,XMIN,XMAX,IPRES)
        IF (IPRES.NE.0) CALL ECROBJ('LISTREEL',IPRES)
 
      ELSEIF(ITOBJ .EQ. 3) THEN
        CALL BORNE3(IPOBJ,MLENTI,MLENT1,MLREE1,MLREE2,IPRES)
        IF (IPRES.NE.0) CALL ECROBJ('EVOLUTIO',IPRES)
 
      ELSEIF(ITOBJ .EQ. 4) THEN
        CALL BORNE4(IPOBJ,MLMOTS,MLENT1,MLREE1,MLREE2,IPRES)
        IF (IPRES.NE.0) THEN
          CALL ACTOBJ('CHPOINT ',IPRES,1)
          CALL ECROBJ('CHPOINT ',IPRES)
        ENDIF
 
      ELSEIF(ITOBJ .EQ. 5) THEN
        CALL BORNE5(IPOBJ,MLMOTS,MLENT1,MLREE1,MLREE2,IPRES)
        IF (IPRES.NE.0) THEN
          CALL ACTOBJ('MCHAML  ',IPRES,1)
          CALL ECROBJ('MCHAML  ',IPRES)
        ENDIF
 
      ELSE
        CALL ERREUR(5)
      ENDIF
 
* ===
*  4 - Menage des objets temporaires
* ===
 900  CONTINUE
      IF (ITOBJ.EQ.3 .OR. ITOBJ.EQ.4 .OR. ITOBJ.EQ.5) THEN
        IF (ITOBJ.EQ.3) THEN
          SEGSUP,MLENTI
        ELSEIF(ITOBJ.EQ.4 .OR. ITOBJ.EQ.5) THEN
          SEGSUP,MLMOTS
        ENDIF
        SEGSUP,MLENT1,MLREE1,MLREE2
      ENDIF
 
      END
 
 

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