subroutine equdip (npeq,tdtet,tdphi,tdr,dteteq,dphieq,dreq,ier) c* c*********************************************************************** c* c* "Copyright [c] CNES 98 - tous droits reserves" c* ********************************************** c* c*PRO MAGLIB c* c*VER 99.03.31 - V 1.0 c*VER 01.06.05 - V 2.0 c*VER 03.01.06 - V 2.1 c* c*AUT spec. CNES - JC KOSIK - janvier 1991 c*AUT port. CISI c* c*ROL Theme : Calculs de geophysique c*ROL Calcul de l'intersection de la ligne de champ avec c*ROL l'equateur geographique terrestre. c* c*PAR npeq (I) : indice courant du point de la ligne de champ c* c*PAR tdtet (I) : tableau des colatitudes dipolaires (radians) c*PAR tdphi (I) : tableau des longitudes dipolaires (radians) c*PAR tdr (I) : tableau des distances dipolaires (rayons terrestres) c* c*PAR dteteq (O) : colatitude geocentrique du point equatorial c*PAR : de la ligne de champ (radians) c*PAR dphieq (O) : longitude geocentrique du point equatorial c*PAR : de la ligne de champ (radians) c*PAR dreq (O) : distance radiale geocentrique du point equatorial c*PAR : de la ligne de champ (rayons terrestres) c* c*PAR ier (O) : code de retour c* c*NOT tableaux : les tableaux tdtet, tdphi et tdr sont dimentionnes a 500 c* c*NOT dteteq : vaut PI / 2 c* c*NOT ier : sans objet c SLG c*NOT ier : 0 = OK c*NOT ier : 1 = division par 0. c SLG c* c*NOT common : util c* c*INF utilise : sans objet c* c*HST version 1.0 - 99.03.31 - creation de la maglib au CDPP c*HST version 2.0 - 01.06.05 - correction de commentaires de code c*HST version 2.1 - 03.01.06 - corrections en compilation avec g77 c* c*********************************************************************** c* implicit none c c --------------------------------- c*FON Declaration identificateur rcs_id c --------------------------------- c character rcs_id*100 c c -------------------------- c*FON Declaration des parametres c -------------------------- c integer npeq double precision tdtet(500), tdphi(500), tdr(500) double precision dteteq, dphieq, dreq integer ier c c ---------------------------------- c*FON Declaration des variables communes c ---------------------------------- c double precision pi,dpi,rad,deg,pid,xmu,rayt c c*COM pi : constante pi (obtenue a partir de acos(-1.)) c*COM dpi : constante 2 * pi c*COM pid : constante pi / 2 c*COM rad : facteur de conversion degres ----> radians c*COM deg : facteur de conversion radians ----> degres c*COM xmu : constante de gravitation terrestre (km**3/sec**2) c*COM rayt : rayon equatorial terrestre (km) c common/util/pi,dpi,rad,deg,pid,xmu,rayt c c --------------------------------- c*FON Declaration des variables locales c --------------------------------- c double precision a1,a2,a3,a4,a5,a6,a7 c*LOC a1,a2,a3,a4,a5,a6,a7 : termes des equations c double precision thetpp,thetp,thet c*LOC thetpp,thetp,thet : colatitudes dipolaires c double precision tphipp,tphip,tphi c*PAR tphipp,tphip,tphi : longitudes dipolaires c double precision trpp,trp,tr c*PAR trpp,trp,tr : distances dipolaires c c ----------------------------------------- c*FON Declaration de la fonction interne pinter c ----------------------------------------- c double precision pinter c SAVE c c --------------------------------- c*FON Affectation identificateur rcs_id c --------------------------------- c data rcs_id /" >$Id$"/ c c ---------------------------------------- c*FON Definition de la fonction interne pinter c ---------------------------------------- c pinter(a1,a2,a3,a4,a5,a6,a7) = > ((a2 - a3) * (a7 - a2) * (a7 - a3) * a4 > - (a1 - a3) * (a7 - a1) * (a7 - a3) * a5 > + (a1 - a2) * (a7 - a2) * (a7 - a1) * a6) > / ((a1 - a2) * (a2 - a3) * (a1 - a3)) c c ****************** c Debut de programme c ****************** c ier = 0 c thetpp = tdtet(npeq-2) thetp = tdtet(npeq-1) thet = tdtet(npeq) trpp = tdr(npeq-2) trp = tdr(npeq-1) tr = tdr(npeq) tphipp = tdphi(npeq-2) tphip = tdphi(npeq-1) tphi = tdphi(npeq) dteteq = pid dreq = pinter(thetpp,thetp,thet,trpp,trp,tr,dteteq) dphieq = pinter(thetpp,thetp,thet,tphipp,tphip,tphi,dteteq) c c **************** c Fin de programme c **************** c return end