Sources Esope | Cast3M

lichpo
C LICHPO    SOURCE    CB215821  20/11/25    13:33:36     10792          
      SUBROUTINE LICHPO(NBAND,ITLACC,IMAX1,IRET,IFORM,LCOMLU)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C=======================================================================
C   BUT        : LECTURE D UN CHAMPOIN
C   APPELE PAR : LIPIL
C   APPELLE    : LFCDIM LFCDIE LFCDI2
C   ECRIT PAR FARVACQUE    -REPRIS PAR LENA
C
C  (E) LCOMLU  : Longueur des Noms de composantes a lire (depuis NIVEAU 23)
C
C=======================================================================
-INC SMCHPOI
-INC PPARAM
-INC CCOPTIO
C
C
C=======================================================================
      SEGMENT/ITBBE1/( ITABE1(NN))
      SEGMENT/ITBBE2/( ITABE2(NN))
      SEGMENT/ITBBM1/( ITABM1(NM))
      segment itbbc1
       character*(LCOMLU) itabc1(nm)
      endsegment
*      segment itbbc2
*       character*4 itabc2(nm2)
*      endsegment
      SEGMENT/ITBBM2/( ITABM2(NM2))
      SEGMENT/ITLACC/( ITLAC(0))
      DIMENSION ILENA(10)
      character*80 itabc2
      external long
C--------------------------------------------------------------------
      IRET  =0
      IRETOU=0
C     **************************CHPOINT*********************************
      NN=0
      NM=0
      NM2=20
       ITBBM2 =0
       ITBBE1 =0
       ITBBM1 =0
       ITBBE2 =0
      SEGINI ITBBM2
 
      IF(IONIVE .LT. 23)THEN
C       Les noms des composantes sont lus sur 4 caracteres pour les CHPOINT
        LCOMLU=4
      ENDIF
 
      SEGINI ITBBM1,itbbc1
*      SEGINI ITBBM2
*      SEGINI ITBBM1
      SEGINI ITBBE2
      SEGINI ITBBE1
C      write(6,*)' lichpo imax1 iobnive iform' , imax1 ,ionive,iform
      DO 1101 IEL=1,IMAX1
C
C               MODIF ATTRIBUT DANS CHPO PAR DEGAY
      IF ( IONIVE .GE. 6 ) THEN
        NTOTO=4
      ELSE
        NTOTO=3
      ENDIF
      MCHPOI=0
      do 36 k=1,4
   36 ilena(k)=0
      CALL LFCDIE(NBAND,NTOTO,ILENA,IRETOU,IFORM)
      IF (IRETOU.NE.0) GO TO 1000
      NSOUPO = ILENA(1)
      NM     = ILENA(2)
      J      = ILENA(3)
C      write(6,*) ' '
C      write(6,*) ' '
C      write(6,*) ' chpoint ' ,iel , ' nsoupo ' , nsoupo, 'nm', nm
      IF ( IONIVE .GE. 6 ) THEN
        NAT    = ILENA(4)
      ELSE
C               UN SEUL ATTRIBUT SUR LES VIEUX CHPO
        NAT = 1
      ENDIF
*
*  JE NE SAIT PAS A QUOI NI A QUI CA SERT
*  MAIS MOI CA ME DESSERT - PV -
*     ITEST= NSOUPO+NM+J
*     IF (ITEST.EQ.0) GO TO 11
      SEGINI MCHPOI
      IFOPOI=J
      NN=3*NSOUPO
      SEGADJ ITBBE1
      SEGADJ ITBBM1,itbbc1
      SEGADJ ITBBM1
C      write(6,*) ' lichpo deuxieme appel a lfcdie nn ' , nn
      CALL LFCDIE(NBAND,NN,ITABE1,IRETOU,IFORM)
C      write(6,*) ' apres 2eme enreg iretou' , iretou
      IF(IRETOU.NE.0) GOTO 1000
C      write(6,*) ' av troisieme appel lfcdim nm',nm
 
      IF(IONIVE .LT. 23)THEN
        if (iform.ne.2) CALL LFCDIM(NBAND,NM,ITABM1,IRETOU,IFORM)
        if (iform.eq.2) call lfdien(nband,itbbC1,iretou,iform)
      ELSE
C       Depuis le niveau 23 on simplifie
        call lfdien(nband,itbbC1,iretou,iform)
      ENDIF
C      write(6,*) ' apres 3eme enreg iretou' , iretou
      IF(IRETOU.NE.0) GOTO 1000
      NN=NM
      SEGADJ ITBBE2
C      write(6,*) ' av 4éme appel lfcdie nn ' , nn
      CALL LFCDIE(NBAND,NN,ITABE2,IRETOU,IFORM)
C      write(6,*) ' apres 4eme enreg iretou' , iretou
      IF(IRETOU.NE.0) GOTO 1000
C      write(6,*) ' av 5éme appel lfcdim nm2 ' , nm2
      if (iform.ne.2) CALL LFCDIM(NBAND,NM2,ITABM2,IRETOU,IFORM)
      if (iform.eq.2) call lfcdic(nband,itabc2(1:80),iretou,iform)
C      write(6,*) ' apres 5eme enreg iretou' , iretou
      IF(IRETOU.NE.0) GOTO 1000
      if (iform.ne.2) then
      WRITE (MTYPOI,FMT='(2A4)') ITABM2(1),ITABM2(2)
      WRITE (MOCHDE,FMT='(18A4)') (ITABM2(I+2),I=1,18)
      endif
      if (iform.eq.2) then
      mtypoi=itabc2(1:8)
      mochde=itabc2(9:80)
      endif
C               MODIF DES CHPO PAR DEGAY
      IF ( IONIVE .GE. 6 ) THEN
C       write(6,*) ' av 6eme appel lfcdie nat ' , nat
        CALL LFCDIE(NBAND,NAT,JATTRI,IRETOU,IFORM)
C      write(6,*) ' apres 6eme enreg iretou' , iretou
        IF (IRETOU .NE. 0) GOTO 1000
      ELSE
C               LE VIEUX CHPO RESTITUE EST INDETERMINE
        JATTRI(1) = 0
      ENDIF
C---
      ICC=0
C      write(6,*) ' nsoupo av boucle', nsoupo
      IF (NSOUPO.EQ.0) GO TO 13
      DO 1103 ISOU=1,NSOUPO
      NC=ITABE1(3*ISOU)
      SEGINI MSOUPO
      IPCHP(ISOU)=MSOUPO
      IGEOC=-abs(ITABE1(3*ISOU -2))
      N=ITABE1(3*ISOU -1)
C      write(6,*) ' isou nc n igeoc ', isou, nc, n , igeoc
      DO 1102 IC=1,NC
        ICC=ICC+1
        IF(IONIVE .LT. 23)THEN
          if (iform.ne.2) WRITE (NOCOMP(IC),FMT='(A4)') ITABM1(ICC)
          if (iform.eq.2) nocomp(ic)=itabc1(icc)
        ELSE
C         Depuis le niveau 23 on simplifie
          ILONG=LONG(itabc1(icc))
          IF(ILONG .GT. LOCOMP)THEN
            INTERR(1)=ILONG
            INTERR(2)=LOCOMP
            MOTERR=itabc1(icc)(1:LOCOMP)
            CALL ERREUR(-373)
          ENDIF
          nocomp(ic)=itabc1(icc)
        ENDIF
        NOHARM(IC)=ITABE2(ICC)
 1102 CONTINUE
 
      SEGINI MPOVAL
      IPOVAL=MPOVAL
      LMAX=N*NC
C      WRITE(6,*) ' ON APPELE LFCDIE AVEC LMAX = ' , LMAX
      CALL LFCDI2(NBAND,LMAX,VPOCHA,IRETOU,IFORM)
      IF(IRETOU.NE.0) GOTO 1000
      SEGDES MPOVAL
      segdes MSOUPO
 1103 CONTINUE
  13  CONTINUE
      SEGDES MCHPOI
   11 ITLAC(**)=MCHPOI
 1101 CONTINUE
      GO TO 1098
 1000 CONTINUE
C      write(6,*) ' lihpo on tombe en 1000'
      IRETOU=1
      IF(MCHPOI.NE.0) SEGSUP MCHPOI
 1098 CONTINUE
      IRET=IRETOU
      IF (ITBBM1.NE.0) SEGSUP ITBBM1,itbbc1
      IF (ITBBM2.NE.0) SEGSUP ITBBM2
      IF (ITBBE1.NE.0) SEGSUP ITBBE1
      IF (ITBBE2.NE.0) SEGSUP ITBBE2
      RETURN
C -------------------------------------------------------
      END