C DFER      SOURCE    PV        07/11/23    21:16:26     5978           
        SUBROUTINE DFER
      IMPLICIT INTEGER(I-N)
        IMPLICIT REAL*8(A-H,O-Z) 
-INC SMELEME
-INC CCGEOME
-INC CCOPTIO
-INC SMCOORD
-INC TMTRAV
-INC SMCHPOI

        SEGMENT PAQUET
           INTEGER LIGNE(NELEM)
        ENDSEGMENT      
        SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
        SEGMENT IDCP(ITE)
        
c        write(6,*)'ok'
        CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
        IF (IERR.NE.0) RETURN
        CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
        IF (IERR.NE.0) RETURN
        CALL LIRREE(XVAL,0,iretou)
        Zi=0.3
        if(iretou.ne.0) ZI=xval
C
C       IPT1 MAILLAGE BETON
C       IPT2 MAILLAGE FER
C
C Création des lignes
        II=IPT2
        JJ=0
*        write(6,*) ' appel a paqlis'
        CALL PAQLIG(II,KK)
*         write(6,*) ' ierr ' ,ierr
        if(ierr.ne.0) return
        PAQUET=KK
        segact paquet
*        write(6,4732) ( ligne (io),io=1,ligne(/1))
 4732   format (10i7)
*        write(6,*) ' retpur de paqlis'
C
C
        ITE=0
        SEGACT IPT1
        IPT3=IPT1
        SEGINI ICPR
        DO 1 I=1,MAX(1,IPT1.LISOUS(/1))
             IF (IPT1.LISOUS(/1).NE.0) THEN
                IPT3=IPT1.LISOUS(I)
                SEGACT IPT3
             ENDIF            
          DO 4 L=1,IPT3.NUM(/2)
             DO 3 JJ=1,IPT3.num(/1)                  
                        IPOIT=IPT3.NUM(JJ,L)
                        IF (ICPR(IPOIT).NE.0) GOTO 3
                        ITE=ITE+1
                        ICPR(IPOIT)=ITE
   3         CONTINUE 
   4      CONTINUE
        IF (IPT1.LISOUS(/1).NE.0) SEGDES IPT3 
   1    CONTINUE
        SEGDES IPT1
        NBNN=1
        NBELEM=ITE
        NBSOUS=0
        NBREF=0
        SEGINI MELEME
        ITYPEL=1
        ia=1
        DO I=1,ICPR(/1)
         IF (ICPR(I).NE.0) then   
           NUM(1,ia)=I
           ia=ia+1
           endif
        END DO
        SEGSUP ICPR
        SEGACT PAQUET
        NC=1
        SEGINI MSOUPO
        IGEOC=MELEME
        N=NBELEM
        SEGINI MPOVAL
        DO 6 I=1,NUM(/2)
           CHB=0.
           J=0
           IREF=num(1,i)*(IDIM+1)-IDIM
           XP=XCOOR(IREF)
           YP=XCOOR(IREF+1)
           ZP=XCOOR(IREF+2)
           IF (IDIM.EQ.2) THEN
              ZP=0.
           END IF
c          write(*,*)'xp',xp,'yp',yp,'zp',zp
           DO WHILE (J.NE.LIGNE(/1))
              J=J+1
              DIST=10E15 
              na=LIGNE(J)
              IREFA=NA*(IDIM+1)-IDIM
              XA=XCOOR(IREFA)
              YA=XCOOR(IREFA+1)
              ZA=XCOOR(IREFA+2) 
              IF (IDIM.EQ.2) THEN
                 ZA=0.
              END IF
              j=j+1
              if(i.eq.1) then
*                  write(6,*) ' point de depart ' , na
              endif
              DO WHILE (LIGNE(J).NE.0)
c                write(6,*)ligne(j)
                 nb=LIGNE(J)    
              if(i.eq.1) then
*                  write(6,*) nb
              endif             
                 IREFB=NB*(IDIM+1)-IDIM
                 XB=XCOOR(IREFB)
                 YB=XCOOR(IREFB+1)
                 ZB=XCOOR(IREFB+2)
                 IF (IDIM.EQ.2) THEN
                    ZB=0.
                 END IF

                 CALL DISTAN(XP,XA,XB,YP,YA,YB,ZP,ZA,ZB,
     $                     DISTINT,MARQ)
c                if (marq.eq.0) then
c                write(*,*)'xa',xa,'ya',ya,'za',za
c                write(*,*)'xb',xb,'yb',yb,'zb',zb
c                end if
                 IF (MARQ.NE.0) THEN
                    xl1=((XB-XP)**2+(YB-YP)**2+(ZB-ZP)**2)**0.5
                    xl2=((XA-XP)**2+(YA-YP)**2+(ZA-ZP)**2)**0.5
                    DISTINT=MIN(xl1,xl2)
                 ENDIF
                 IF (DISTINT.LE.DIST) THEN
                     DIST=DISTINT
                 ENDIF
                 J=J+1 
                 xa=xb
                 ya=yb
                 za=zb
              END DO
              CHB=CHB+XINFLU(DIST,ZI)
c              write(6,*)'dist',dist,'influen',XINFLU(DIST,ZI)
c              write(6,*)'idcp',idcp(i),'chp',chb
c               if (XINFLU(DIST,ZI).ne.0) then
c                  write(*,*)'xp',xp,'yp',yp,'zp',zp
c                  write(*,*)'xa',xa,'ya',ya,'za',za
c                  write(*,*)'xb',xb,'yb',yb,'zb',zb 
c                  write(6,*)jjelem,'chp',chb
c                  write(6,*)'dist',dist,'influen',XINFLU(DIST,ZI)
c               endif
           END DO
           VPOCHA(I,1)=CHB

  6     CONTINUE
        IPOVAL=MPOVAL
        NOCOMP(1)='DFER'
        SEGDES MPOVAL
        NSOUPO=1
        NAT=1
        SEGINI MCHPOI
        JATTRI(1)=2
        IPCHP(1)=MSOUPO
        MOCHDE='MANUEL'
        SEGDES MSOUPO,meleme
        SEGDES IPT2,IPT1
        CALL ECROBJ('CHPOINT ',MCHPOI)
        RETURN
        END