Sources Esope | Cast3M

linuag
C LINUAG    SOURCE    PV        05/04/13    21:15:55     5073
      SUBROUTINE LINUAG(IORES,ITLACC,IMAX1,IRET,IFORM)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C=======================================================================
C   BUT        : LECTURE D UN NUAGE
C   APPELE PAR : LIPIL
C   APPELLE    : LFCDIM LFCDIE LFCDI2
C=======================================================================
C=======================================================================
-INC SMNUAGE
-INC CCFXDR
C
C
C=======================================================================
      SEGMENT/ITBBE1/( ITABE1(NN))
      SEGMENT/ITBBM1/( ITABM1(NM))
      segment itbbc1
       character*4 itabc1(nm)
      endsegment
      SEGMENT/ITLACC/( ITLAC(0))
      DIMENSION ILENA(2)
      CHARACTER*8 CTYP
C--------------------------------------------------------------------
      IRET=0
      DO 1101 IEL=1,IMAX1
*      write(6,fmt='(''    nuage numero '',i6)') iel
      NTOTO=2
      CALL LFCDIE(IORES,NTOTO,ILENA,IRETOU,IFORM)
      IF (IRETOU.NE.0) GO TO 1000
      NVAR = ILENA(1)
      NBCOUP=ILENA(2)
*      write(6,fmt='( ''nvar nbcoup  '' , 2I6)') nvar,nbcoup
      NM     = 4*NVAR
      SEGINI ITBBM1,itbbc1
      SEGINI MNUAGE
      if (iform.ne.2) CALL LFCDIM(IORES,NM,ITABM1,IRETOU,IFORM)
      if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc1(1)(1:nm*4))
*      write(6,fmt='('' nuanomtyp '',/,(6a10))') (itabm1(lk),lk=1,nm)
      IF(IRETOU.NE.0) GOTO 1000
      DO 1 I=1,NVAR
      J = 4*I-3
      if (iform.ne.2) then
      WRITE (NUANOM(I),FMT='(2A4)') ITABM1(J),ITABM1(J+1)
      WRITE (NUATYP(I),FMT='(2A4)') ITABM1(J+2),ITABM1(J+3)
      else
      nuanom(i)(1:4)=itabc1(j)
      nuanom(i)(5:8)=itabc1(j+1)
      nuatyp(i)(1:4)=itabc1(j+2)
      nuatyp(i)(5:8)=itabc1(j+3)
      endif
   1  CONTINUE
      SEGSUP ITBBM1,itbbc1
      DO 2 I= 1,NVAR
       CTYP = NUATYP(I)
       IF( CTYP.EQ.'FLOTTANT') THEN
           SEGINI NUAVFL
           NUAPOI(I)= NUAVFL
           CALL LFCDI2(IORES,NBCOUP,NUAFLO,IRETOU,IFORM)
           IF(IRETOU.NE.0) GOTO 1000
           SEGDES NUAVFL
        ELSEIF(CTYP.EQ.'MOT     ') THEN
           SEGINI NUAVMO
           NUAPOI(I)=NUAVMO
           NM = NBCOUP*2
           SEGINI ITBBM1,itbbc1
           if (iform.ne.2) CALL LFCDIM(IORES,NM,ITABM1,IRETOU,IFORM)
           if (iform.eq.2) ios=IXDRSTRING( ixdrr, itabc1(1)(1:nm*4))
           IF(IRETOU.NE.0) GOTO 1000
           DO 3 K=1,NBCOUP
           J=2*K -1
           if (iform.ne.2) then
           WRITE (NUAMOT(K),FMT='(2A4)') ITABM1(J),ITABM1(J+1)
           else
           nuamot(k)(1:4)=itabc1(j)
           nuamot(k)(5:8)=itabc1(j+1)
           endif
    3      CONTINUE
           SEGDES NUAVMO
           SEGSUP ITBBM1,itbbc1
        ELSEIF(CTYP.EQ.'LOGIQUE ') THEN
           SEGINI NUAVLO
           NUAPOI(I)= NUAVLO
           NN=NBCOUP
           SEGINI ITBBE1
           CALL LFCDIE(IORES,NN,ITABE1,IRETOU,IFORM)
           IF(IRETOU.NE.0) GOTO 1000
           DO 4 K=1,NN
           IF( ITABE1(K).EQ.1) THEN
               NUALOG(K)=.TRUE.
           ELSE
               NUALOG(K)=.FALSE.
           ENDIF
   4       CONTINUE
           SEGSUP ITBBE1
           SEGDES NUAVLO
        ELSE
           SEGINI NUAVIN
           NUAPOI(I)=NUAVIN
           CALL LFCDIE(IORES,NBCOUP,NUAINT,IRETOU,IFORM)
           IF(IRETOU.NE.0) GOTO 1000
           SEGDES NUAVIN
        ENDIF
    2 CONTINUE
      SEGDES MNUAGE
      ITLAC(**)=MNUAGE
*      write(6,fmt='(''   fin du nuage'')')
 1101 CONTINUE
      RETURN
 1000 CONTINUE
      IRET=1
      IF(MNUAGE.NE.0) SEGSUP MNUAGE
      RETURN
C -------------------------------------------------------
      END