
C	subroutine for rpress.f etc

C	Sven Ivansson  1990




	SUBROUTINE U2TEST (QFAKT,UA2LOK,UB2LOK)
C	test conditions from Hudson p. 18, 206-207
ccc NOT YET IMPLEMENTED FOR ANISOTROPIC LAYER

	IMPLICIT NONE

	INCLUDE 'RPPARAMETER.INC'
C       nol <= noldim

	INCLUDE 'INMODEL.INC'    ! only to get iazimi

	REAL*8 QFAKT
	COMPLEX*16 UA2LOK,UB2LOK

	REAL*8 VELPHASE,DBL
	COMPLEX*16 CSLASK

	IF (IAZIMI.NE.0) RETURN          ! no test performed in this case

	IF (DREAL(UA2LOK).LT.0.0D0) GOTO 999
	IF (DIMAG(UA2LOK).LT.0.0D0) GOTO 999
	IF (UB2LOK.NE.(0.0D0,0.0D0)) THEN
	  IF (DREAL(UB2LOK).LT.0.0D0) GOTO 999
	  IF (DIMAG(UB2LOK).LT.0.0D0) GOTO 999
	  CSLASK = 1/UA2LOK - (4.0D0/3)/UB2LOK
	  IF (DREAL(CSLASK).LT.0.0D0) GOTO 999
	  IF (DIMAG(CSLASK).GT.0.0D0) GOTO 999
	END IF

	RETURN

 999	WRITE(*,*)
	WRITE(*,*) ' %%% u2test failure'
	CALL U2TOREAL ( QFAKT,UA2LOK, VELPHASE,DBL )
	WRITE(*,*) '  for P ',SNGL(VELPHASE),SNGL(DBL)
	CALL U2TOREAL ( QFAKT,UB2LOK, VELPHASE,DBL )
	WRITE(*,*) '  for S ',SNGL(VELPHASE),SNGL(DBL)
	WRITE(*,*) '  bulk modulus modulo rho'
	IF (UB2LOK.NE.(0.0D0,0.0D0)) THEN
	  CSLASK = 1/UA2LOK - (4.0D0/3)/UB2LOK
	ELSE
	  CSLASK = 1/UA2LOK
	END IF
	WRITE(*,*) '        ',CSLASK
	WRITE(*,*) '  shear modulus modulo rho'
	IF (UB2LOK.NE.(0.0D0,0.0D0)) THEN
	  CSLASK = 1/UB2LOK
	ELSE
	  CSLASK = (0.0D0,0.0D0)
	END IF
	WRITE(*,*) '        ',CSLASK
	WRITE(*,*) '  both these moduli should have been in the ',
     $	'fourth quadrant'
	WRITE(*,*)
	STOP 605

	END
