C XSOUR     SOURCE    CHAT      05/01/13    04:15:00     5004
      SUBROUTINE XSOUR(FN,FM,GR,PG,XYZ,HR,PGSQ,RPG,
     & NES,IDIM,NP,MP,NPG,IAXI,LE,IKAS,KPRE,
     & RGE,IKG,NELG,IPADQ,LS,
     & TN,IKT,TREF,IKR,IPADS,
     & NBEL,K0,XCOOR,F,NPT)

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)

C************************************************************************
C
C   OPERATEUR SOUR
C - IKAS = 1 Source scalaire    s :  FLOTTANT ou CHPOINT SCAL CENTRE
C - IKAS = 2 Source QDM         s :  POINT    ou CHPOINT SCAL CENTRE
C - IKAS = 3 Source QDM         g*beta*( T - Tref )
C
C************************************************************************

      DIMENSION FM(MP,NPG),FN(NP,NPG),GR(IDIM,NP,NPG),PG(NPG)
      DIMENSION XYZ(IDIM,NP),HR(NES,NP,NPG),PGSQ(NPG),RPG(NPG)
      DIMENSION XCOOR(*)
      DIMENSION RGE(NELG,IDIM),LS(MP,*)
      DIMENSION LE(NP,NBEL),F(NPT,IDIM),IPADQ(*),IPADS(*)
      DIMENSION TN(*),TREF(*)
C***********************************************************************
C     write(6,*)' Debut XSOUR IKAS=',ikas
C     write(6,*)' MP,NELG,NP,NPT=',MP,NELG,NP,NPT
C     write(6,*)' IPADS '
C     write(6,1001)(IPADS(ii),ii=1,100)
C     write(6,*)' IPADQ '
C     write(6,1001)(IPADQ(ii),ii=1,100)
C     write(6,*)' LE '
C     write(6,1001)le

      IF(IKAS.EQ.1)THEN
C Cas source scalaire
      NK=K0
      DO 108 KE=1,NBEL
      NK=NK+1
      DO 109 I=1,NP
      J=LE(I,KE)
      DO 109 N=1,IDIM
      XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N)
 109  CONTINUE

      CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
     *IDIM,NP,NPG,IAXI,AIRE)

      DO 103 I=1,NP
      I1=IPADS(LE(I,KE))
      U=0.D0
      DO 102 J=1,MP
      J1=IPADQ(LS(J,NK))
      NKG=1+(1-IKG)*(J1-1)
      DO 101 L=1,NPG
      U=U+FN(I,L)*FM(J,L)*PGSQ(L)*RGE(NKG,N)
 101  CONTINUE
 102  CONTINUE
      F(I1,1)=F(I1,1)+U
 103  CONTINUE
 108  CONTINUE
C     write(6,*)' F '
C     write(6,1002)F
C     write(6,*)' XSOUR FIN '
      RETURN

      ELSEIF(IKAS.EQ.2)THEN

      NK=K0
      DO 208 KE=1,NBEL
      NK=NK+1
      DO 209 I=1,NP
      J=LE(I,KE)
      DO 209 N=1,IDIM
      XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N)
 209  CONTINUE

      CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
     *IDIM,NP,NPG,IAXI,AIRE)

      DO 204 N=1,IDIM
      DO 203 I=1,NP
      I1=IPADS(LE(I,KE))
      U=0.D0
      DO 202 J=1,MP
      J1=IPADQ(LS(J,NK))
      NKG=1+(1-IKG)*(J1-1)
      DO 201 L=1,NPG
      U=U+FN(I,L)*FM(J,L)*PGSQ(L)*RGE(NKG,N)
 201  CONTINUE
 202  CONTINUE
      F(I1,N)=F(I1,N)+U
 203  CONTINUE
 204  CONTINUE
 208  CONTINUE
C     write(6,*)' F '
C     write(6,1002)F
C     write(6,*)' XSOUR FIN '
      RETURN

      ELSEIF(IKAS.EQ.3)THEN

      NK=K0
      DO 308 KE=1,NBEL
      NK=NK+1
      DO 309 I=1,NP
      J=LE(I,KE)
      DO 309 N=1,IDIM
      XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N)
 309  CONTINUE

      CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
     *IDIM,NP,NPG,IAXI,AIRE)

      NKG=1+(1-IKG)*(NK-1)

      DO 304 N=1,IDIM
      DO 303 I=1,NP
      I1=IPADS(LE(I,KE))

      U=0.D0
      DO 301 L=1,NPG

      TT=0.D0
      DO 305 IB=1,NP
      IB1=IPADS(LE(IB,KE))
      NKT=1+(1-IKT)*(IB1-1)
      NKR=1+(1-IKR)*(IB1-1)
      TT=TT+FN(IB,L)*(TN(NKT)-TREF(NKR))
 305  CONTINUE
      U=U+FN(I,L)*PGSQ(L)*TT
 301  CONTINUE
      F(I1,N)=F(I1,N)-U*RGE(NKG,N)
 303  CONTINUE
 304  CONTINUE
 308  CONTINUE
C     write(6,*)' F '
C     write(6,1002)F
C     write(6,*)' XSOUR FIN '
      RETURN


      ENDIF



 1002 FORMAT(8(1X,1PE11.4))
 1001 FORMAT(20(1X,I5))
      END