Télécharger ryo2v.eso

Retour à la liste

ryo2v
C RYO2V     SOURCE    CB215821  20/11/25    13:39:35     10792          
      SUBROUTINE RYO2V(IRT)
C*************************************************************************
C
C
C
C
C
C*************************************************************************
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMTABLE
-INC SMLMOTS
-INC SMELEME
      POINTEUR MELEMC.MELEME
-INC SMCOORD
 
-INC SMMATRIK
      POINTEUR MAT1.MATRIK,MAT2.MATRIK,MAT3.MATRIK
-INC SMCHPOI
C      POINTEUR IZV1.MCHPOI,IZVV1.MPOVAL
C      POINTEUR IZV2.MCHPOI,IZVV2.MPOVAL
 
      DIMENSION XVEC(3)
      CHARACTER*8 TYPE,TYPC,TYPE1,TYPE2
      LOGICAL LDMULT
      PARAMETER (NBOP=12)
      CHARACTER*4 MOT4
      CHARACTER*8 LOPER(NBOP),MTYP,NOMI
      DATA LOPER/'CMCT    ','RIMA    ','NINCDUPR','NINCPRDU',
     $     'EXTRNINC',
     $     'EXTRINCO','POINTEUR','EXTRDIAG','SPAIDIAG','RELA    ',
     $     'CONDENSE','EVAPORE '/
C***
C     ********************************************
C     * La premiere partie de cette routine      *
C     * consiste a recuperer les arguments de    *
C     * l operateur KOPS afin de pouvoir leurs   *
C     * attribuer le traitement correspondant    *
C     ********************************************
 
C     On saisit le premier objet de la pile
C     *************************************
 
      CALL QUETYP(MTYP,0,IRET)
      IF(IRET.EQ.0)THEN
      IRT=1
      RETURN
      ENDIF
C     write(6,*)' KOPS nag=',nag,' MTYP=',MTYP
 
C     ============================================
C     Cas : Objet = MOT
C     ============================================
      IRT=0
      IF(MTYP.NE.'MOT')THEN
      IRT=1
      RETURN
      ELSE
         CALL LIRMOT(LOPER,NBOP,KOP,1)
C     write(6,*)' KOPS ', LOPER(KOP)
C         write(6,*) 'Avant KOPS ', LOPER(KOP)
         IF(KOP.EQ.0)THEN
         IRT=1
         RETURN
         ENDIF
      ENDIF
 
C Cas tres tres particulier(s)
 
C CAS KOP=1
      IF(KOP.EQ.1 )THEN
         CALL PRCMCT
C         write(6,*) 'Apres KOPS ', LOPER(KOP)
         RETURN
      ENDIF
C CAS KOP=2
      IF(KOP.EQ.2 )THEN
         CALL RIMA
C         write(6,*) 'Apres KOPS ', LOPER(KOP)
         RETURN
      ENDIF
      IF(KOP.EQ.3)THEN
         CALL MACHI2(1)
C         write(6,*) 'Apres KOPS ', LOPER(KOP)
         RETURN
      ENDIF
      IF(KOP.EQ.4)THEN
         CALL MACHI2(2)
C         write(6,*) 'Apres KOPS ', LOPER(KOP)
         RETURN
      ENDIF
* Mot clé non disponible, voir l'opérateur EXTR 'COMP'
      IF(KOP.EQ.5)THEN
         CALL EXTIPD
C         write(6,*) 'Apres KOPS ', LOPER(KOP)
         RETURN
      ENDIF
      IF(KOP.EQ.6)THEN
         CALL EXINCO
C         write(6,*) 'Apres KOPS ', LOPER(KOP)
         RETURN
      ENDIF
      IF(KOP.EQ.7)THEN
         MTYP='        '
         CALL LIROBJ(MTYP,IRET,1,IRETOU)
         IF (IERR.NE.0) RETURN
         CALL ECRENT(IRET)
C         write(6,*) 'Apres KOPS ', LOPER(KOP)
         RETURN
      ENDIF
      IF(KOP.EQ.8)THEN
         CALL EXDIAG(1)
C         write(6,*) 'Apres KOPS ', LOPER(KOP)
         RETURN
      ENDIF
      IF(KOP.EQ.9)THEN
         CALL EXDIAG(2)
C         write(6,*) 'Apres KOPS ', LOPER(KOP)
         RETURN
      ENDIF
      IF(KOP.EQ.10)THEN
         CALL RELRIG
C         write(6,*) 'Apres KOPS ', LOPER(KOP)
         RETURN
      ENDIF
*
* Condense les relations
*
      IF(KOP.EQ.11)THEN
         CALL LIROBJ('RIGIDITE',MRIGID,1,IRET)
         IF (IERR.NE.0) RETURN
         CALL LIROBJ('CHPOINT ',KSMBR,1,IRET)
         IF (IERR.NE.0) RETURN
*     On ne dédouble pas les multiplicateurs ici
         LDMULT=.FALSE.
*     On élimine les relations ici, c'est le but
         NELIM=1
         CALL KRES6(MRIGID,KSMBR,LDMULT,NELIM,
     $        MRIGIC,KSMBRC,KSMBR1)
* 2018/10/08 Gérer le cas où il n'y a pas de chpoint ksmbr1 (ksmbr1=0)
         if (ksmbr1.eq.0) then
            call ecrent(ksmbr1)
         else
            CALL ECROBJ('CHPOINT ',KSMBR1)
         endif
         CALL ECROBJ('CHPOINT ',KSMBRC)
         CALL ECROBJ('RIGIDITE',MRIGIC)
         RETURN
      ENDIF
*
* Evapore : opération inverse de la condensation
*
      IF(KOP.EQ.12)THEN
         CALL LIROBJ('CHPOINT ',MSOLC,1,IRET)
         IF (IERR.NE.0) RETURN
         CALL LIROBJ('RIGIDITE',MRIGID,1,IRET)
         IF (IERR.NE.0) RETURN
         CALL LIROBJ('CHPOINT ',KSMBR,1,IRET)
         IF (IERR.NE.0) RETURN
         CALL LIRENT(KSMBR1,0,IRET)
         IF (IRET.EQ.0) THEN
            CALL LIROBJ('CHPOINT ',KSMBR1,1,IRET)
         ELSE
            if (ksmbr1.ne.0) call erreur(5)
         ENDIF
         IF (IERR.NE.0) RETURN
* Ne pas détruire le champ solution, c'est un objet utilisateur Gibiane         
         IDTARG=0
         CALL KRES7(MSOLC,MRIGID,KSMBR,KSMBR1,IDTARG,
     $        MCHSOL)
         IF (IERR.NE.0) RETURN
         CALL ECROBJ('CHPOINT ',MCHSOL)
         RETURN
      ENDIF
      RETURN
      END
 
 
 
 
 
 
 

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