#include "cfx5ext.h"
dllexport(user_source2)
      SUBROUTINE USER_SOURCE2 (
     & NLOC,NRET,NARG,RET,ARGS,CRESLT,CZ,DZ,IZ,LZ,RZ)
C--------------------
C       Details
C --------------------
C  ARGS(1:NLOC,1) holds parameter ?a? evaluated at all locations
C  RET(1:NLOC,1)  will hold return result
C ------------------------------
C     Preprocessor includes
C ------------------------------
#include "MMS.h"
#include "stack_point.h"
C ------------------------------
C        Argument list
C ------------------------------
      INTEGER NLOC,NARG,NRET
      CHARACTER*(4) CRESLT
      REAL ARGS(NLOC,NARG), RET(NLOC,NRET)
      INTEGER IZ(*)
      CHARACTER CZ(*)*(1)
      DOUBLE PRECISION DZ(*)
      LOGICAL LZ(*)
      REAL RZ(*)
C ------------------------------
C        External routines
C ------------------------------
      INTEGER LENACT
      EXTERNAL LENACT
C ------------------------------
C        Local Variables
C ------------------------------
      CHARACTER*(MXDNAM) ACTION,CGROUP,CEQN,CTERM,CPVAR,
     & CLVAR,CPATCH,CRESLOC,CPHASE
      CHARACTER*120 User_Phase_Name, User_Variable_Name
C ------------------------------
C        Stack pointers
C ------------------------------
      __stack_point__ pGRAD_PHI
C ---------------------------
C    Executable Statements
C ---------------------------
C  Initialise success flag.
      CRESLT = 'GOOD'
C  Initialise RET to zero.
      CALL SET_A_0 ( RET, NLOC*NRET )
C
C---- Determine user?s phase name for use in USER_GETVAR
C
C  Use USER_ASSEMBLE_INFO to determine solver equation and principal
C  variable names CEQN, CPVAR.
      ACTION = 'GET'
      CALL USER_ASSEMBLE_INFO (ACTION,CGROUP,CEQN,CTERM,CPVAR,
     &  CLVAR,CPATCH,CRESLOC,
     & CZ,DZ,IZ,LZ,RZ)
      IF (CRESLOC.NE.'GOOD' .AND. CRESLOC.NE.'SOME') THEN
         CRESLT = 'FAIL'
         GO TO 999
      ENDIF
C  Extract phase name from principal variable
      CALL GET_PHASE_FROM_VAR (CPVAR, CPHASE)
C  Convert solver phase name to user phase name.
      CALL CONVERT_NAME_S2U('Phase',CPHASE,' ',User_Phase_Name,
     & CRESLT, CZ,DZ,IZ,LZ,RZ)
      IF (CRESLT .NE. 'GOOD') GO TO 999
C
C---- Obtain grad(phi1)
C     in array shape GRAD_PHI(1:3,1:NLOC) located at RZ(pGRAD_PHI)
C
      User_Variable_Name = User_Phase_Name(1:LENACT(User_Phase_Name))
     & // '.phi1.Gradient'
      CALL USER_GETVAR (User_Variable_Name, CRESLT, pGRAD_PHI,
     & CZ,DZ,IZ,LZ,RZ)
      IF (CRESLT .NE. 'GOOD') GO TO 999
C
C---- Calculate source expression in RET(1:NLOC,1)
C
      CALL USER_SOURCE_CAL( RET(1,1), ARGS(1,1), RZ(pGRAD_PHI), NLOC )
C
  999 CONTINUE
C
C  Send any diagnostics or stop requests via master processor
      IF (CRESLT .NE. 'GOOD') THEN
         CALL MESAGE( 'BUFF', 'USER_SOURCE2 returned error:' )
         CALL MESAGE( 'BUFF', CRESLT )
         CALL MESAGE( 'BUFF-OUT', ' ' )
      END IF
C
C=======================================================================
      END
      SUBROUTINE USER_SOURCE_CAL (SOURCE, A, GRAD_PHI, NLOC)
C
C  Purpose: Source = a * grad(phi).grad(phi)
C
C  Inputs
      INTEGER NLOC
      REAL A(NLOC), GRAD_PHI(3,NLOC)
C  Outputs
      REAL SOURCE(NLOC)
C  Locals
      INTEGER ILOC
C
      DO ILOC = 1, NLOC
          SOURCE(ILOC) = A(ILOC) * ( GRAD_PHI(1,ILOC)**2
     &     + GRAD_PHI(2,ILOC)**2
     &     + GRAD_PHI(3,ILOC)**2 )
      END DO
C
      END
