C------------------------------------------------------------------------------ C nrho.for C------------------------------------------------------------------------------ C 24 Mar 2010 - Added CALL PDENSITYa C 24 Mar 2010 - Added CALL PDENSITYg (with arguments) C 24 Mar 2010 - Added ENTRY DENSITYg (with arguments) C 4 May 2009 - replaced REAL*8 with DOUBLE PRECISION C 14 May 2007 - Different entry points for acoustics and gravity C 19 Jul 2006 - Separated idensity (no argument) and idensityg (w. argument) C 13 Jul 2006 - Corrections C 12 Jul 2006 C------------------------------------------------------------------------------ SUBROUTINE NRHO C------------------------------------------------------------------------------ C GENERIC DENSITY MODEL implicit DOUBLE PRECISION (a-h,o-z) C TYPE :: model CHARACTER :: model_name REAL(KIND=8) :: data_id CHARACTER :: pert_name REAL(KIND=8) :: pert_id END TYPE model TYPE (model) :: moddg TYPE :: values_and_derivs_1_2 REAL(KIND=8) :: value REAL(KIND=8) :: ptm,pr,pth,pph REAL(KIND=8) :: ptmtm,prtm,pthtm,pphtm REAL(KIND=8) :: ptmr,prr,pthr,pphr REAL(KIND=8) :: ptmth,prth,pthth,pphth REAL(KIND=8) :: ptmph,prph,pthph,pphph END TYPE TYPE (values_and_derivs_1_2) :: rho TYPE (values_and_derivs_1_2) :: potentialrho C COMMON DECK "WW" INSERTED HERE common/ww/ dum(10),maxw,w(1000) C C DENSITY 650-674 EQUIVALENCE (W(650),DMODEL),(W(651),DFORM),(W(652),DID) C C COMMON DECK "DS" INSERTED HERE REAL(KIND=8) ds,modds COMMON/DS/MODDS(4),ds,pdst,pdsr,pdsth,pdsph C COMMON DECK "B15" INSERTED HERE INTEGER TMX,TNTBL,TITBL,TFRMTBL,IDST(10) COMMON/B15/TMX,TNTBL(10),TITBL(10),TFRMTBL(10),TGP(262) EQUIVALENCE (TGP,IDST),(ANT,TGP(11)) INTEGER TYMX,TYNTBL(10),TYITBL(10),TYFRMTBL(10) C DATA RECOGD/0.d0/ DATA TYMX/1/ DATA TYNTBL/1,11,8*0/ DATA TYITBL/1,9*0/ DATA TYFRMTBL/1,9*0/ C C------------------------------------------------------------------------------ ENTRY SETdensity TMX=TYMX CALL IMOVE(TNTBL,TYNTBL,10) CALL IMOVE(TITBL,TYITBL,10) CALL IMOVE(TFRMTBL,TYFRMTBL,10) ! 13 July 2006 CALL SETPDENSITY ! 13 July 2006 RETURN C C------------------------------------------------------------------------------ ENTRY Idensity IF(idint(RECOGD) .NE. idint(DMODEL)) 1 CALL RERROR('NRHO ','WRNG MODEL',RECOGD) C MODDS(1)=4HNRHO MODDS(2)=DID CALL IPdensity ! 13 July 2006 RETURN C ENTRY Idensityg(moddg) IF(idint(RECOGD) .NE. idint(DMODEL)) 1 CALL RERROR('NRHO ','WRNG MODEL',RECOGD) C moddg%model_name = 'NRHO' moddg%data_id = did moddg%pert_name = '' moddg%pert_id = 0.d0 CALL IPdensityg(moddg) ! 19 July 2006 RETURN C------------------------------------------------------------------------------ ENTRY DENSITYg(rho,potentialrho) ! 24 Mar 2010 CALL PDENSITYg(rho,potentialrho) ! 24 Mar 2010 RETURN ENTRY density ENTRY densitya ! 14 May 2007 CALL PDENSITYa ! 24 Mar 2010 RETURN C------------------------------------------------------------------------------ END SUBROUTINE NRHO C------------------------------------------------------------------------------