Télécharger la plaquette Cast3M


fr en

Télécharger rescha.eso

Retour à la liste

Numérotation des lignes : 

rescha

  1. C RESCHA    SOURCE    OF166741  24/10/03    21:15:38     12022          
  2.       SUBROUTINE RESCHA (ICOLAC,ITLACC,IMAX1,IDEB)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. *--------------------------------------------------------------------*
  6. *                                                                    *
  7. *     Restauration des pointeurs issus de la pile des CHAMELEMs.     *
  8. *                                                                    *
  9. *--------------------------------------------------------------------*
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC SMCHAML
  14. -INC TMCOLAC
  15.       CHARACTER*8  MOTIP
  16.       CHARACTER*16 NOCOMP
  17. *
  18. *     Boucle sur les CHAMELEMs contenus dans la pile:
  19. *
  20.       ITLAC1 = KCOLA(1)
  21.       ITLAC3 = KCOLA(48)
  22.       DO 10 IEL =IDEB,IMAX1
  23.          MCHELM = ITLAC(IEL)
  24.          IF (MCHELM.EQ.0) GOTO 10
  25.          SEGACT,MCHELM*MOD
  26.          NSOUEL = ICHAML(/1)
  27.          IF (NSOUEL.EQ.0) GOTO 10
  28.          DO 20 ISOU=1,NSOUEL
  29.             MCHAML=ICHAML(ISOU)
  30.             IF (MCHAML.EQ.0) GO TO 20
  31.                SEGACT,MCHAML*MOD
  32.  
  33.                IVA = IMACHE(ISOU)
  34.                IF (IVA.NE.0) IMACHE(ISOU) = ITLAC1.ITLAC(ABS(IVA))
  35.  
  36.                ITLAC2 = KCOLA(40)
  37.                IVA = INFCHE(ISOU,4)
  38.                IF (IVA.LT.0) INFCHE(ISOU,4) = ITLAC2.ITLAC(ABS(IVA))
  39.  
  40.                NCO = TYPCHE(/2)
  41.                DO 30 ICO=1,NCO
  42.                   NOCOMP = TYPCHE(ICO)
  43.                   IF (NOCOMP(1:6).NE.'REAL*8') THEN
  44.                      MOTIP(1:8)=NOCOMP(9:16)
  45.                      CALL TYPFIL(MOTIP,ITYP)
  46.                      IF(ITYP.LE.0) GO TO 30
  47.                      ITLAC2 = KCOLA(ITYP)
  48.                      MELVAL = IELVAL(ICO)
  49.                      IF (MELVAL.NE.0) THEN
  50.                         SEGACT,MELVAL*MOD
  51.                         N1 = IELCHE(/1)
  52.                         N2 = IELCHE(/2)
  53.                         DO 40 I2=1,N2
  54.                         DO 50 I1=1,N1
  55.                         IVA = IELCHE(I1,I2)
  56.                         IF (IVA.LT.0)
  57.      &                      IELCHE(I1,I2) = ITLAC2.ITLAC(ABS(IVA))
  58.  50                     CONTINUE
  59.  40                     CONTINUE
  60.                         SEGDES,MELVAL
  61.                      ENDIF
  62.                   ELSE
  63. **                     write(ioimp,*) ' rescha iva ',ielval(ico)
  64.                      IVA = IELVAL(ICO)
  65.                      IF (IVA.LT.0) IELVAL(ICO)=ITLAC3.ITLAC(ABS(IVA))
  66. **                     write(ioimp,*) ' rescha apres ',ielval(ico)
  67.                   ENDIF
  68.  30            CONTINUE
  69.             SEGDES,MCHAML
  70.  20         CONTINUE
  71.          segdes mchelm
  72.  10     CONTINUE
  73.       RETURN
  74.       END
  75.  
  76.  
  77.  

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