c###geom.for
      SUBROUTINE GEOM
C--------------------------------
C
C     THIS ROUTINE CALCULATES THE PATH GEOMETRY
C
C MAPIN IS -1,IF DATA TAPE HAS NOT BEEN READ.
      common /Cnorth_pole/ g_magnetic_lat,g_magnetic_lon  !  magnetic north pole
C
      COMMON / ALPHA / IMON(12), ITRAN(2), IRCVR(2), LBMAP(2), MODE(13),
     A MODER(13), ITLAT, ITLONG, IRLAT, IRLONG, IRLATU, IRLONGU, NYEAR
      CHARACTER IMON*3, NYEAR*5, ITRAN*10, IRCVR*10, LBMAP*10, ITLAT*1,
     A ITLONG*1, IRLAT*1, IRLONG*1, IRLATU*1, IRLONGU*1, MODE*2, MODER*2
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RZ, VOFL
      COMMON /DON /ALATD, AMIN, AMIND, BTR, BTRD, DLONG, DMP, ERTR, GCD,
     1 GCDKM, PMP, PWR, TLAT, TLATD, TLONG, TLONGD, RSN, SIGTR, RLAT,
     2 RLATD,RLONG,RLONGD,BRTD,FLUX,ULAT,ULATD,ULONG,ULONGD,SSN,D90R,
     3 D50R,D10R,D90S,D50S,D10S
      COMMON / ION / IHRE, IHRO, IHRS, LUFP, METHOD, NOISE, NPSL
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      COMMON/GEOG/ GYZ(5), RAT(5), GMDIP(5), CLCK(5), ABIY(5), ARTIC(5),
     1 SIGPAT(5), EPSPAT(5)
      COMMON / OUTLAB / LABEL(11), LAYTYP(5), IEAST, INORTH, ISOUTH,
     A IWEST, LABLI, LABLJ, LABLK
      CHARACTER IEAST*1, ISOUTH*1, INORTH*1, IWEST*1, LABEL*5, LAYTYP*2,
     A LABLI*5, LABLJ*5, LABLK*5
      DATA EPSLON/1.E-7/
      data ddx/.03/      !  closest Tx & Rx can be
C.....RADIUS OF THE EARTH (RZ)
      BK = R2D
      AK = D2R
C.....GEOMAGNETIC NORTH POLE, LATITUDE, LONGITUDE, MINIMUM
C.....TAKE OFF ANGLE SERVICE PROBABILITY FACTOR
C.....LATITUDE SOUTH IS "-" AND LATITUDE NORTH IS "+"
C.....LONGITUDE EAST IS "+" AND LONGITUDE WEST IS "-"
ccc      GLT = 78.5 * D2R
ccc      GLG = -69.0 * D2R
      GLT = g_magnetic_lat * D2R      !  see routine set_magnetic_pole
      GLG = g_magnetic_lon * D2R
      if(abs(tlatd-rlatd).le.ddx .and. abs(tlongd-rlongd).le.ddx) then
c          move Rx away from Tx a little bit
         dd=ddx
         if(rlatd.lt.0.) dd=-ddx
         rlatd=tlatd-dd
      end if
      TLAT = TLATD * D2R
      TLONG = TLONGD * D2R
      RLAT = RLATD * D2R
      RLONG = RLONGD * D2R
      if(abs(rlatd).gt.89.9) rlong=0.     !  at poles, force long=0
      if(abs(tlatd).gt.89.9) tlong=0.     !  at poles, force long=0
C     GREAT CIRCLE DISTANCE AND BEARINGS.
 100  DLONG = TLONG - RLONG
      IF (ABS (DLONG) .GT. PI) DLONG = DLONG - SIGN (PI2, DLONG)
C.....FOR LONG GREAT CIRCLE PATH
      IF (NPSL .EQ. 1) DLONG = DLONG - SIGN (PI2, DLONG)
      QCOS=SIN(TLAT)*SIN(RLAT)+COS(TLAT)*COS(RLAT)*COS(DLONG)
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
      GCD = ACOS (QCOS)
C.....MINIMUM DISTANCE IS 31.85 METERS
      IF(GCD.LT.0.000001) GCD = 0.000001
C.....FOR GREAT CIRCLE PATH
      IF (NPSL .EQ. 1) GCD = PI2 - GCD
      GCDKM = GCD * RZ
C.....CHECK IF TRANSMITTER IS NEAR A POLE
      IF(COS(TLAT) - EPSLON) 101, 101, 104
C.....TRANSMITTER IS NEAR A POLE
  101 IF (TLAT) 102,102,103
  102 BTR= 0.0
      GO TO 106
  103 BTR = PI
      GO TO 106
C.....TRANSMITTER IS NOT NEAR A POLE
  104 CONTINUE
      QCOS=(SIN(RLAT)-SIN(TLAT)*COS(GCD))/(COS(TLAT)*SIN(GCD))
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
C.....BTR IS BEARING, TRANSMITTER TO RECEIVER
      BTR = ACOS (QCOS)
  106 CONTINUE
      IF (DLONG .GT. 0.0) BTR = PI2 - BTR
C.....CHECK IF RECEIVER IS NEAR A POLE
      IF(COS(RLAT) - EPSLON) 111, 111, 114
C.....RECEIVER IS NEAR A POLE
  111 IF( RLAT )  112,112,113
  112 BRT = 0.
      GO TO 116
  113 BRT=PI
      GO TO 116
C.....RECEIVER IS NOT NEAR A POLE
  114 CONTINUE
      QCOS=(SIN(TLAT)-SIN(RLAT)*COS(GCD))/(COS(RLAT)*SIN(GCD))
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
C.....BRT IS BEARING, RECEIVER TO TRANSMITTER
      BRT = ACOS (QCOS)
  116 CONTINUE
      IF (DLONG .LT. 0.0) BRT = PI2 - BRT
C.....CONVERT BEARINGS TO DEGREES
      BTRD = BTR * R2D
      BRTD = BRT * R2D
C     DETERMINATION OF REFLECTION AREAS.
C SELECT SAMPLE AREAS IN ORDER
      IF(GCDKM.le.2000.01) then
C.....KM IS THE NUMBER OF SAMPLE AREAS
         KM=1
         RD(1)= GCD/2.
      else if(GCDKM.le.4000.) then
         KM=3
         RD(1) = 1000. / RZ
         RD(2)= GCD/2.
         RD(3)= GCD -RD(1)
      else
         KM= 5
         RD(1) = 1000. / RZ
         RD(2)= RD(1)+RD(1)
         RD(3)= GCD/2.
         RD(4)= GCD-RD(2)
         RD(5)= GCD-RD(1)
      end if
ccc      write(12,'(''in geom, km='',i5,f10.2)') km,gcdkm
C.....RD(1) IS E LAYER, RD(2) IS F LAYER, RD(3) IS ALL LAYERS,
C.....RD(4) IS F LAYER AND RD(5) IS E LAYER
C     REFLECTION AREA COORDINATES AND GEOMAGNETIC LATITUDE.
66    IF(KM.LT.1) GO TO 185
      DO 180 I = 1, KM
      DRF = RD (I)
      CTLAT = COS(TLAT)
C.....CHECK IF TRANSMITTER IS NEAR A POLE
      IF(CTLAT - EPSLON) 71, 76, 76
C.....TRANSMITTER IS NEAR A POLE
   71 RFLT = TLAT - SIGN(DRF,TLAT)
      IF(ABS(RFLT).gt.PIO2) RFLT=PIO2*sign(1.,RFLT)
      RFLG=RLONG
      GO TO 80
C.....TRANSMITTER IS NOT NEAR A POLE
   76 CONTINUE
      QCOS=COS(DRF)*SIN(TLAT)+SIN(DRF)*COS(TLAT)*COS(BTR)
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
      RFLT = PIO2 - ACOS (QCOS)
C.....CHECK IF THE SAMPLE AREA IS NEAR A POLE
      IF(COS(RFLT) - EPSLON) 78, 78, 79
C.....SAMPLE AREA IS NEAR A POLE
   78 RFLG = TLONG
      GO TO 80
C.....SAMPLE AREA IS NOT NEAR A POLE
   79 CONTINUE
      QCOS=(COS(DRF)-SIN(RFLT)*SIN(TLAT))/(COS(RFLT)*COS(TLAT))
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
      RFLG = ACOS (QCOS)
      IF (DRF .GE. PI) RFLG = PI2 - RFLG
      RFLG = TLONG - SIGN (RFLG, DLONG)
      IF (ABS (RFLG) .GT. PI) RFLG = RFLG - SIGN (PI2, RFLG)
   80 CONTINUE
      QCOS=SIN(GLT)*SIN(RFLT)+COS(GLT)*COS(RFLT)*COS(RFLG-GLG)
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
C.....GLAT(I) IS THE GEOMAGNETIC LATITUDE
C.....CLAT(I) IS THE GEOGRAPHIC LATITUDE
C.....CLONG(I) IS THE GEOGRAPHIC LONGITUDE
      GAT = ACOS (QCOS)
      GLAT (I) = PIO2 - GAT
      CLAT (I) = RFLT
      CLONG (I) = RFLG
C.....MAGNETIC FIELD VARIABLES.
C....CLG IS THE GEOGRAPHIC EAST LONGITUDE(SAVED FOR CALL TO NOISY)
      CLG = RFLG
      CALL MAGVAR(RFLT,RFLG,I,CLG)
C.....CHECK TO SEE IF MAP AVAILABLE IS CONSISTANT WITH BEARING
ccc      IF(MAPIN.le.0) go to 115
C.....OBTAIN LAND MASS MAP
         RFLTD = RFLT * R2D
         CLGD = CLG * R2D
         IF(CLGD.LT.0.)CLGD=CLGD+360.
         CALL NOISY(7,RFLTD,CLGD,WLD)
      IF(WLD.ge.0) go to 115
C.....GROUND CONSTANTS FOR SEA
         SIGPAT (I) = 5.
         EPSPAT (I) = 80.
         go to 120
C.....GROUND CONSTANTS FOR LAND
115      SIGPAT (I) = 0.001
         EPSPAT (I) = 4.
 120  CONTINUE
  180 CONTINUE
 185  CONTINUE
      ALATD=ABS(CLAT(1))*R2D
      IF(KM.NE.1) ALATD=ABS((CLAT(1)+CLAT(2)+CLAT(3))/3.0)*R2D
ccc      write(12,'(''glat='',5e15.7)') (glat(i),i=1,km)
      RETURN
      END
C--------------------------------
