C
C   Copyright (c) 1997 Silvano Bonazzola
C
C    This file is part of LORENE.
C
C    LORENE is free software; you can redistribute it and/or modify
C    it under the terms of the GNU General Public License as published by
C    the Free Software Foundation; either version 2 of the License, or
C    (at your option) any later version.
C
C    LORENE is distributed in the hope that it will be useful,
C    but WITHOUT ANY WARRANTY; without even the implied warranty of
C    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C    GNU General Public License for more details.
C
C    You should have received a copy of the GNU General Public License
C    along with LORENE; if not, write to the Free Software
C    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
C
C
	SUBROUTINE LAPP3S(NDEG,NDR,NDT,IPAR,N64,CC,CS,C64,DEN1
     1	,DENT,QQ1,DEN)
C
	IMPLICIT NONE
C
C		ROUTINE POOUR LE CAL CALCUL DU LAPLACIEN D'UNE FONCTION
C		SCALAIRE EN COORDONNES SPHERIQUES A 3 DIM.
C		AVEC ECHANTILLONAGE RAREFIE A L'ORIGINE. LA FONCTION
C
C	L'OPERATEUR EST LE SUIVANT:
C
C	D2/dr2+2*D/dr +(D2/dtheta**2 +COS(theta)/SIN(theta)* D/dtheta-
C	-1/SIN(theta)**2*D2/dfi2)/r**2
C	
C		ARGUMENTS DE LA ROUTINE
C
C	NDEG	=TABLEAU CONTENENT LE NOMBRE DES COEFFICIENTS SELON r ET
C		THETA
C	NDR	=DIMENSION DES TABLEAUX DEN, DENT,QQ1,DEN1
C	IPAR    =DRAPEAU INDIQUENT LES SYMMETRIES:
c
C             IPAR=0 AUCUNE SYMMETRIE
C             IPAR=2 SYMMETRIE PAR RAPPORT LE PLAN z=0	   
C             IPAR=3 ANTISYMMETRIE PAR RAPPORT LEPLAN Z=0 (Non implemente')
C	      IPAR=4 SYMMETRIE PAR RAPPORTLE PLAN z=0 ET PAR RAPPORT
C                    LA TRANSFORMATION x,y -> -x,-y
C	      IPAR=5 ANTI-SYMMETRIE PAR RAPPORTLE PLAN z=0 ET PAR RAPPORT
C                    LA TRANSFORMATION x,y -> -x,-y (Non implemente')
C   
C	N64	=PARAMETRE DE CRAYTINISATION
C	CC	=TABLEAU DE TRAVAIL 
C		 DIMENSIONS > (MAX(NDEG(1),NDEG(2))+2)*MAX((N64+2),NT1+2)
C	CS,C64= TABLEAUX DE TRAVAIL DE 
C		   DIMENSIONS > (MAX(NDEG(1),NDEG(2))+2)*(N64+2)
C	DEN1,DENT,QQ1=TABLEAUX DE TRAVAIL DE LA MEME DIMENSION QUE DEN
C
C	DEN	=TABLEAU  2-3 CONTENENT EN IMPUT LES COEFFICIENTS
C		 DE LA FONCTION DONT ON VEUT CALCULER LE LAPLACIEN ET
C		 EN OUTPUT LE LAPLACIEN
C
C	 N.B
C        ---
C		DAN LE CAS OU IL-Y-AURAIT DE SYMMETRIES
C 		LE LAPLACIEN EST CALCULE DANS LE PREMIER QUADRANT
C		z VARIE ENTRE 0 ET 1, theta ENTRE PI/2 ET 0.
C
C
C $Id: lapp3s.f,v 1.2 2012/03/30 12:12:43 j_novak Exp $
C $Log: lapp3s.f,v $
C Revision 1.2  2012/03/30 12:12:43  j_novak
C Cleaning of fortran files
C
C Revision 1.1.1.1  2001/11/20 15:19:30  e_gourgoulhon
C LORENE
C
c Revision 1.1  1997/10/23  08:08:47  eric
c Initial revision
c
C
C $Header: /cvsroot/Lorene/F77/Source/Poisson2d/lapp3s.f,v 1.2 2012/03/30 12:12:43 j_novak Exp $
C
C
	character*120 header
	data header/'$Header: /cvsroot/Lorene/F77/Source/Poisson2d/lapp3s.f,v 1.2 2012/03/30 12:12:43 j_novak Exp $'/

	INTEGER NR1,NT1,NF,NDR,NDT,N64,NDEG,NDEG1,LR,LT,LF,MQ,K2,IPAR,
     1	LLQ,IPA,MM,J
C
	REAL*8 DENT,DEN,C64,DEN1,QQ1,CC,CS,DE2
C
	DIMENSION NDEG(*),DENT(NDR,NDT,*),DEN(NDR,NDT,*),C64(*)
	DIMENSION DEN1(NDR,NDT,*),QQ1(NDR,NDT,*),CC(*),CS(*),NDEG1(3)
C
	NR1=NDEG(1)
	NT1=NDEG(2)
	NF= NDEG(3)
	IF(NR1+3.GT.NDR.OR.NT1+3.GT.NDT) THEN
	PRINT*,'Routine LAPP#S: TABLEAUX INSUFFISEMENT DIMENSIONES,'
	PRINT*,'NR1,NT1,NDR,NDT=',NR1,NT1,NDR,NDT
	STOP
	ENDIF
C
	IF(IPAR.EQ.0) THEN
C
C		CALCUL DE D2/dtheta2
C
	DO LF=1,NF
	DO LT=1,NT1
	LLQ=-(LT-1)**2
	DO LR=1,NR1
	QQ1(LR,LT,LF)=LLQ*DEN(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
C		CALCUL DE COS(theata)/SIN(theta) * D/dtheta
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	DEN1(LR,LT,LF)=DEN(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,2,0,1,1,CC,CS,C64,DENT,DEN1)
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	QQ1(LR,LT,LF)=QQ1(LR,LT,LF)+DEN1(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
C		ON RETRANCE LE TERME EN 1/SIN(theta)**2 QUI A SERVI
C               A LA REGULARISATION EN SIN(theta))
C
	IF(NF.GT.1) THEN
	DO LF=2,NF,2
	MM=LF/2
	MQ=MM**2
	IPA=1
	IF(MOD(MM,2).EQ.0) IPA=0
	DO J=LF,MIN0(LF+1,NF)
	DO LT=1,NT1
	DO LR=1,NR1
	DEN1(LR,LT,1)=DEN(LR,LT,J)
	ENDDO
	ENDDO
C
C		DIVISION PAR SIN(theta)**2
C
	CALL FCIR2S(NDEG,NDR,N64,2,IPA,4,1,C64,CC,CS,DENT,DEN1)
	DO LT=1,NT1
	DO LR=1,NR1
	QQ1(LR,LT,J)=QQ1(LR,LT,J)-(MQ-IPA)*DEN1(LR,LT,1)
	ENDDO
	ENDDO
	ENDDO
	ENDDO
	ENDIF
C
C		ON RAJOUTE LE TERME EN 2/r**2 QUI SERT POUR LA REGULARISATION
C               EN r
C
	DO LT=2,NT1,2
	DO LR=1,NR1
	QQ1(LR,LT,1)=QQ1(LR,LT,1)+2*DEN(LR,LT,1)
	ENDDO
	ENDDO
C
	DO LF=2,NF,2
	DO J=LF,MIN0(LF+1,NF)
	DO LT=2,NT1,2
	DO LR=1,NR1
	QQ1(LR,LT,J)=QQ1(LR,LT,J)+2*DEN(LR,LT,J)
	ENDDO
	ENDDO
	ENDDO
	ENDDO
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,1,0,4,1,CC,CS,C64,DENT,QQ1)
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	DEN1(LR,LT,LF)=DEN(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,1,0,2,1,CC,CS,C64,DENT,DEN1)
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	QQ1(LR,LT,LF)=QQ1(LR,LT,LF)+DEN1(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,1,0,1,1,CC,CS,C64,DENT,DEN)
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	DEN(LR,LT,LF)=2*DEN(LR,LT,LF)+QQ1(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
	RETURN
	ENDIF
C
c		CAS OU IL Y-A LA SYMMETRIE PAR RAPPORT A z=0
C
	IF(IPAR.EQ.2) THEN
C
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	QQ1(LR,LT,LF)=DEN(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
C		CALCUL DE D2/dtheta2
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,2,20,2,1,CC,CS,C64,DENT,QQ1)
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	DEN1(LR,LT,LF)=DEN(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
C		CALCUL DE COS(theta)/sin(theta)*D/dtheta
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,2,20,1,1,CC,CS,C64,DENT,DEN1)
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	QQ1(LR,LT,LF)=QQ1(LR,LT,LF)+DEN1(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
C
	IF(NF.GT.1) THEN
C
	K2=0
	DO LF=2,NF,2
	DO J=LF,MIN0(LF+1,NF)
	K2=K2+1
	DO LT=1,NT1
	DO LR=1,NR1
	DEN1(LR,LT,K2)=DEN(LR,LT,J)
	ENDDO
	ENDDO
	ENDDO
	ENDDO
	NDEG1(1)=NR1
	NDEG1(2)=NT1
	NDEG1(3)=K2
C
C		DIVISION PAR SIN(theta)**2
C
	CALL DISR3S(NDEG1,NDR,NDT,5,-1,DEN1,DENT)
	CALL DISR3S(NDEG1,NDR,NDT,4,-1,DENT,DEN1)
C
C		ON RETRANCHE LA PARTIE PROVENANT DE D2/dphi2
C
	K2=0
	DO LF=2,NF,2
	IPA=1                       !! IPA factorise le terme qui sert a la
C                                   !! la regularisation en theta
	MM=LF/2
	IF(MOD(MM,2).EQ.0) IPA=0
	MQ=MM**2-IPA
	DO J=LF,MIN0(LF+1,NF)
	K2=K2+1
	DO LT=1,NT1
	DO LR=1,NR1
	QQ1(LR,LT,J)=QQ1(LR,LT,J)-MQ*DEN1(LR,LT,K2)
	ENDDO
	ENDDO
	ENDDO
	ENDDO
	ENDIF
C
C		LA PRTIE ANGULAIRE,CONTENUE EN QQ1  EST DIVISEE PAR r
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,1,2,6,1,CC,CS,C64,DENT,QQ1)
C
C		CALCUL DE D/dr
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	DEN1(LR,LT,LF)=DEN(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,1,2,7,1,CC,CS,C64,DENT,DEN1)
C
C		ON AJIUTE A LA PARTIE AMGULAIRE/r LA DERIVEE PAR RAPPORT
C		A r DE LA FONCTION ...	
c
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	DEN1(LR,LT,LF)=2*DEN1(LR,LT,LF)+QQ1(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C	... QUI VA ETRE DIVEISSE PAR r
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,1,3,6,1,CC,CS,C64,DENT,DEN1)
C
C		CALCUL DE D2/dr2
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,1,2,2,1,CC,CS,C64,DENT,DEN)
C
C		CALCUL FINAL DU LAPLCIEN
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	DEN(LR,LT,LF)=DEN(LR,LT,LF)+DEN1(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
	RETURN
	ENDIF
C
	IF(IPAR.EQ.4) THEN
C
C		CALLCUL DE d2/dtheta**2
C
	DO  LF=1,NF
	DO  LT=2,NT1
	DE2=-(LT+LT-2)**2
	DO  LR=1,NR1
	QQ1(LR,LT,LF)=DEN(LR,LT,LF)*DE2
	ENDDO
	ENDDO
	DO LR=1,NR1
	QQ1(LR,1,LF)=0
	ENDDO
	ENDDO
C
C		CALCUL DU TERME COS(theta)/SIN(theta)*D/dtheta
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	DEN1(LR,LT,LF)=DEN(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,2,40,1,1,CC,CS,C64,DENT,DEN1)
C
	DO LF=1,NF
	DO  LT=1,NT1
	DO  LR=1,NR1
	QQ1(LR,LT,LF)=QQ1(LR,LT,LF)+DEN1(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
C		CALCUL DU TERME 1/SIN(theta)**2*D2/dphi**2
C
	IF(LF.GT.3) THEN
C		
C		DIVISION PAR SIN(theta)**2
C
	DO LF=1,NF
	DO LT=1,NT1
	DO LR=1,NR1
	DEN1(LR,LT,LF)=DEN(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,2,40,4,1,CC,CS,C64,DENT,DEN1)
C
C		CALCUL DE D2/dphi**2
C
	DO LF=2,NF
	K2=-((LF/2)*2)**2
	DO LT=1,NT1
	DO LR=1,NR1
	QQ1(LR,LT,LF)=QQ1(LR,LT,LF)+K2*DEN1(LR,LT,LF)
	ENDDO
	ENDDO
	ENDDO
	ENDIF
C
C		L'OPERATEUR ANGULAIRE EST AINSI CALCULE. IL FAUT MAINTENET
C		le diviser par r**2
C
C		DIVISION PAR r**2 DE TOUS LES TERMES CALCULES PLUS HAUT.
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,1,4,4,1,CC,CS,C64,DENT,QQ1)
C
C		CALCUL DE L'OPERATEUR RADIALE
C
C		CALCUL DERIVEE 2me PAR RAPPORT r.
C
	DO 31 LF=1,NF
	DO 9 LT=1,NT1
	DO 10 LR=1,NR1
	DEN1(LR,LT,LF)=DEN(LR,LT,LF)
  10	CONTINUE
   9	CONTINUE
  31	CONTINUE
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,1,4,2,1,CC,CS,C64,DENT,DEN1)
C
	DO 40 LF=1,NF
	DO 41 LT=1,NT1
	DO 42 LR=1,NR1
	QQ1(LR,LT,LF)=QQ1(LR,LT,LF)+DEN1(LR,LT,LF)
  42	CONTINUE
  41	CONTINUE
  40	CONTINUE
C
C		CALCUL DE 2/r*d/dr POUR LA PARTIE PAIRE ET DE 
C
	CALL FCIR3S(NDEG,NDR,NDT,N64,1,4,1,1,CC,CS,C64,DENT,DEN)
C
	DO 32 LF=1,NF
	DO 11 LT=1,NT1
	DO 12 LR=1,NR1
	DEN(LR,LT,LF)=QQ1(LR,LT,LF)+2*DEN(LR,LT,LF)
  12	CONTINUE
  11	CONTINUE
  32	CONTINUE
	RETURN
	ENDIF
C
	PRINT 101
	PRINT*,'Routine LAPP3S"Ces cas n est pas encore contemple'
	PRINT*,'IPAR=',IPAR
	STOP
C
  100	FORMAT(1X,10E11.3)
  101	FORMAT(1X,' ')
	END

