Sources Esope | Cast3M

ensolf
C ENSOLF    SOURCE    CB215821  20/11/25    13:27:45     10792          
      SUBROUTINE ENSOLF(ICOLAC,IRET,IFORM)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C=======================================================================
C   LECTURE D'UN OBJET MSOLUT SUR LE FICHIER IORES
C
C   APPELE PAR    : LIPIL
C   APPELLE       : LFCDIE ENPAPF  LFCDES LFCDIM
C   ECRIT  PAR    :FARVACQUE -LENA
C
C=======================================================================
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCHPOI
C**-INC SMCHELM
-INC SMSOLUT
-INC TMCOLAC
C====
      SEGMENT/ITBBE1/( ITABE1(NN))
      SEGMENT/ITBBE2/( ITABE2(NN))
      SEGMENT/ITBBE3/( ITABE3(L3,N3))
      SEGMENT/ITAB/(TAB(N1),ITABB(N2))
      DIMENSION ILENA(10),ILECBI(2)
C=======================================================================
C
      IRET=0
      IMEL=0
      MSOLUT=0
C     READ(IORES,8000,END=1000,ERR=1000) NIPO1,MELEME,L3
      NTOTO=3
      CALL LFCDIE (IORES,NTOTO,ILENA(1),IRETOU,IFORM)
      IF(IRETOU.NE.0) GOTO 1000
      NIPO1  =ILENA(1)
      ISOMM=ILENA(1)+ILENA(2)+ILENA(3)
      IF (ISOMM.EQ.0) GO TO 10
      MELEME =ILENA(2)
      L3     =ILENA(3)
      NIPO=NIPO1+4
      SEGINI MSOLUT
      MSOLIS(3)=MELEME
C     READ(IORES,8001,END=1000,ERR=1000) ITYSOL(1),ITYSOL(2)
      NTOTO=2
      CALL LFCDIM (IORES,NTOTO,ILECBI,IRETOU,IFORM)
      WRITE(ITYSOL,FMT='(2A4)')(ILECBI(IY),IY=1,2)
      IF(IRETOU.NE.0) GOTO 1000
      NN=2*NIPO1
      SEGINI ITBBE1
      CALL LFCDIE(IORES,NN,ITABE1,IRETOU,IFORM)
      IF(IRETOU.NE.0) GOTO 1000
      NN=NIPO1+1
      SEGINI ITBBE2
      IBBE2=ITBBE2
      CALL LFCDIE(IORES,NN,ITABE2,IRETOU,IFORM)
      IF(IRETOU.NE.0)GOTO 1000
      N3=ITABE2(NN)
      SEGINI ITBBE3
      L=N3*L3
      CALL LFCDIE(IORES,L,ITABE3,IRETOU,IFORM)
      IF(IRETOU.NE.0) GOTO1000
      DO 1803 III=1,NIPO1
      MSOLIT(III+4) = ITABE1(2*III-1)
      IF(ITABE1(2*III).EQ.0) GOTO 1803
      N=0
      SEGINI MSOLEN
      MSOLIS(III+4)=MSOLEN
 1803 CONTINUE
C
C   ***** CAS DES MODES ET DES SOLUSTAT ET DES PSEUMODES
C
      IF(ITYSOL.EQ.'DYNAMIQU') GOTO 1810
      N=0
      SEGINI MSOLEN
      MSOLIS(4)=MSOLEN
      ITLAC1=KCOLA(1)
      MELEME=ITLAC1.ITLAC(MELEME)
      SEGACT MELEME
      IF(NUM(/2).NE.1) GOTO 1820
      NN=1
      SEGINI ITBBE2
      IMEL=ITBBE2
      ITABE2(1)=NUM(1,1)
 1820 CONTINUE
      SEGDES MELEME
      GOTO 1849
C
C  ***** CAS DES DYNAMIQU
C
 1810 CONTINUE
      IF(ITYSOL.NE.'DYNAMIQU') GOTO 1811
      SEGINI MSOLRE
      MSOLIS(1)=MSOLRE
      GOTO 1849
 1811 CONTINUE
C
C******** DANS TOUS LES CAS : LECTURE PAS A PAS ********************
C
 1849 CONTINUE
      N1=7
      N2=4+NIPO1
      SEGINI ITAB
 1898 CONTINUE
CCCC  READ(IORES,700,END=1899,ERR=1899) IQUOI
      CALL LFCDES (IORES,IQUOI,IRETOU,IFORM)
      IF(IRETOU.NE.0) GOTO 1899
C     IQUOI=6 FIN DU MSOLUT , IQUOI=1 LECTURE D'UN NOUVEAU PAS
      IF(IQUOI.NE.1) GOTO 1899
      CALL ENPAPF(MSOLUT,ITAB,ITBBE1,IBBE2,ITBBE3,IMEL,IRETOU,IFORM)
      IF(IRETOU.EQ.0) GOTO 1898
C
C  ***FIN DE LECTURE DU MSOLUT:ON REGLE LE PB DU MELEME ATTACHE AUX MODE
C
 1899 CONTINUE
C  ON SEGACT MSOLUT CAR IL EST DESACTIVE DANS ENPAPF
      SEGACT MSOLUT
      ITBBE2=IBBE2
      SEGSUP ITAB,ITBBE2,ITBBE3
      IF(IMEL.EQ.0) GOTO 1897
      ITBBE2=IMEL
      SEGACT ITBBE2
      NBSOUS=0
      NBREF=0
      NBNN=1
      NPAS=ITABE2(/1)
      IF(NPAS.EQ.0) GOTO 1000
      NBELEM=NPAS
      SEGINI MELEME
      DO 1896 I=1,NPAS
      NUM(1,I)=ITABE2(I)
 1896 CONTINUE
      ITYPEL=1
      MSOLIS(3)=-MELEME
      SEGDES MELEME
C
C   **** ECRITURE COMPLETE DES CHPOINTS,MCHELM ... CONTENUS DANS LES
C   **** MSOLEN
C
 1897 CONTINUE
      ITLAC1=KCOLA(1)
      ITLAC2=KCOLA(11)
      ITLAC3=KCOLA(2)
      ITLAC4=KCOLA(5)
C
      DO 4805 II=5,NIPO
      IF(MSOLIS(II).EQ.0.OR.MSOLIT(II).EQ.0) GOTO 4805
      MSOLEN=MSOLIS(II)
      SEGACT MSOLEN
      N=ISOLEN(/1)
      IF(N.EQ.0) GOTO 1000
      III=II-4
      IIVA=ITABE1(2*III)
C
C  ** MCHPOI ++++++++++++++
      IF(MSOLIT(II).NE.2) GOTO 4811
      MCHPO1=ITLAC3.ITLAC(IIVA)
      SEGACT MCHPO1
      NSOUPO=MCHPO1.IPCHP(/1)
      DO 4834 ISOU=1,NSOUPO
      MSOUP1=MCHPO1.IPCHP(ISOU)
      SEGACT MSOUP1
 4834 CONTINUE
      DO 4830 J=1,N
      IF(ISOLEN(J).EQ.0) GOTO 4830
      MCHPOI=ISOLEN(J)
      SEGACT MCHPOI
      MTYPOI=MCHPO1.MTYPOI
      MOCHDE=MCHPO1.MOCHDE
      DO 4831 ISOU=1,NSOUPO
      MSOUPO=IPCHP(ISOU)
      MSOUP1=MCHPO1.IPCHP(ISOU)
      SEGACT MSOUPO
      NC=NOCOMP(/2)
      DO 4832 IC=1,NC
 4832 NOCOMP(IC)=MSOUP1.NOCOMP(IC)
      IGEOC=ITLAC1.ITLAC(MSOUP1.IGEOC)
      SEGDES MSOUPO
 4831 CONTINUE
      SEGDES MCHPOI
 4830 CONTINUE
      DO 4833 ISOU=1,NSOUPO
      MSOUP1=MCHPO1.IPCHP(ISOU)
      SEGDES MSOUP1
 4833 CONTINUE
      SEGDES MCHPO1
      GOTO 4806
C
 4811 IF(MSOLIT(II).NE.5) GO TO 4812
C     MCHAML +++++++++++++++++
      MCHEL1=ITLAC4.ITLAC(IIVA)
C*    SEGACT MCHEL1
C*    NSOU=MCHEL1.IELVAL(/1)
C*    DO 4836 J=1,N
C*    IF(ISOLEN(J).EQ.0) GOTO 4836
C*    MCHELM=ISOLEN(J)
C*    SEGACT MCHELM
C*    MTYELM=MCHEL1.MTYELM
C*    MTYELM=MCHEL1.MTYELM
C*    IFOCHE=MCHEL1.IFOCHE
C*    IMGCH1=MCHEL1.IMGCH1
C*    MOCHEL=MCHEL1.MOCHEL
C*    IF (NSOU.EQ.0) GO TO 4840
C*    DO 4839 ISOU=1,NSOU
C*    INUM(ISOU)=MCHEL1.INUM(ISOU)
C*    IAFF(ISOU)=ITLAC2.ITLAC(MCHEL1.IAFF(ISOU))
C*    IHARMO(ISOU)=MCHEL1.IHARMO(ISOU)
 4839 CONTINUE
 4840 CONTINUE
C*    SEGDES MCHELM
 4836 CONTINUE
C*    SEGDES MCHEL1
C
 4812 CONTINUE
 4806 CONTINUE
      SEGDES MSOLEN
 4805 CONTINUE
      IRET=MSOLUT
      IF(IQUOI.NE.6) IRET=-IRET
      SEGDES MSOLUT
 1000 CONTINUE
   10 RETURN
      END