/[PAMELA software]/DarthVader/OrbitalInfo/src/igrf_sub.for
ViewVC logotype

Diff of /DarthVader/OrbitalInfo/src/igrf_sub.for

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by mocchiut, Thu Jan 16 15:29:26 2014 UTC revision 1.10 by mocchiut, Fri Aug 29 07:06:41 2014 UTC
# Line 55  C*************************************** Line 55  C***************************************
55  C  C
56  C  C
57        SUBROUTINE FINDB0(STPS,BDEL,VALUE,BEQU,RR0)        SUBROUTINE FINDB0(STPS,BDEL,VALUE,BEQU,RR0)
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
58  C--------------------------------------------------------------------  C--------------------------------------------------------------------
59  C FINDS SMALLEST MAGNETIC FIELD STRENGTH ON FIELD LINE  C FINDS SMALLEST MAGNETIC FIELD STRENGTH ON FIELD LINE
60  C  C
# Line 72  C          BEQU   MAGNETIC FIELD STRENGT Line 70  C          BEQU   MAGNETIC FIELD STRENGT
70  C          RR0    EQUATORIAL RADIUS NORMALIZED TO EARTH RADIUS  C          RR0    EQUATORIAL RADIUS NORMALIZED TO EARTH RADIUS
71  C          BDEL   FINAL ACHIEVED ACCURACY  C          BDEL   FINAL ACHIEVED ACCURACY
72  C--------------------------------------------------------------------  C--------------------------------------------------------------------
       REAL(8) P  
73        DIMENSION         P(8,4),SP(3)        DIMENSION         P(8,4),SP(3)
74        LOGICAL           VALUE        LOGICAL           VALUE
75        COMMON/FIDB0/     SP        COMMON/FIDB0/     SP
# Line 157  C        DO 1111 I=1,8 Line 154  C        DO 1111 I=1,8
154  C  C
155  C  C
156        SUBROUTINE SHELLG(GLAT,GLON,ALT,DIMO,FL,ICODE,B0)        SUBROUTINE SHELLG(GLAT,GLON,ALT,DIMO,FL,ICODE,B0)
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
157  C--------------------------------------------------------------------  C--------------------------------------------------------------------
158  C CALCULATES L-VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE  C CALCULATES L-VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE
159  C AND GEMAGNETIC FIELD MODEL.  C AND GEMAGNETIC FIELD MODEL.
# Line 195  C                          WHICH ACCURAT Line 190  C                          WHICH ACCURAT
190  C                          APPROXIMATION IS USED.  C                          APPROXIMATION IS USED.
191  C          B0           MAGNETIC FIELD STRENGTH IN GAUSS  C          B0           MAGNETIC FIELD STRENGTH IN GAUSS
192  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
       REAL(8) AQUAD,BQUAD,ERA  
       REAL(8) CT,ST,D,ALT,X,RQ,P,U,STEP  
193        DIMENSION         V(3),U(3,3),P(8,100),SP(3)        DIMENSION         V(3),U(3,3),P(8,100),SP(3)
194        COMMON            X(3),H(196)        COMMON            X(3),H(196)
195        COMMON/FIDB0/     SP        COMMON/FIDB0/     SP
196        SAVE /FIDB0/        SAVE /FIDB0/
197        COMMON/GENER/     ERA,AQUAD,BQUAD,UMR        COMMON/GENER/     UMR,ERA,AQUAD,BQUAD
198        SAVE /GENER/        SAVE /GENER/
199  C  C
200  C-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3  C-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3
# Line 356  C Line 349  C
349  C-- Correct dipole moment is used here. D. Bilitza, Nov 87.  C-- Correct dipole moment is used here. D. Bilitza, Nov 87.
350  C  C
351        DIMOB0=DIMO/B0        DIMOB0=DIMO/B0
352        arg1=dlog(FI)        arg1=alog(FI)
353        arg2=dlog(DIMOB0)        arg2=alog(DIMOB0)
354  c    arg = FI*FI*FI/DIMOB0  c    arg = FI*FI*FI/DIMOB0
355  c    if(abs(arg).gt.88.0) arg=88.0  c    if(abs(arg).gt.88.0) arg=88.0
356        XX=3*arg1-arg2        XX=3*arg1-arg2
# Line 385  c  771 GG=3.33338E-1*XX+3.0062102E-1     Line 378  c  771 GG=3.33338E-1*XX+3.0062102E-1    
378       1E-3)*XX+1.2038224E-1)*XX-1.8461796E-1)*XX+2.0007187E0                   1E-3)*XX+1.2038224E-1)*XX-1.8461796E-1)*XX+2.0007187E0            
379        GOTO777                                                                  GOTO777                                                          
380    776 GG=XX-3.0460681E0                                                    776 GG=XX-3.0460681E0                                                
381    777 FL=EXP(dLOG((1.+EXP(GG))*DIMOB0)/3.0)    777 FL=EXP(ALOG((1.+EXP(GG))*DIMOB0)/3.0)
382        RETURN                                                                    RETURN                                                            
383  C*****APPROXIMATION FOR HIGH VALUES OF L.                                C*****APPROXIMATION FOR HIGH VALUES OF L.                              
384  30    ICODE=3                                                            30    ICODE=3                                                          
# Line 396  C*****APPROXIMATION FOR HIGH VALUES OF L Line 389  C*****APPROXIMATION FOR HIGH VALUES OF L
389  C  C
390  C  C
391        SUBROUTINE STOER(P,BQ,R)                                                  SUBROUTINE STOER(P,BQ,R)                                          
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
   
392  C*******************************************************************  C*******************************************************************
393  C* SUBROUTINE USED FOR FIELD LINE TRACING IN SHELLG                *  C* SUBROUTINE USED FOR FIELD LINE TRACING IN SHELLG                *
394  C* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD SUBROUTINE FELDG   *  C* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD SUBROUTINE FELDG   *
395  C*******************************************************************  C*******************************************************************
       REAL(8) P,ZM,FLI,WR,XM,R,YM,XI,DR  
396        DIMENSION         P(7),U(3,3)        DIMENSION         P(7),U(3,3)
397        COMMON            XI(3),H(196)        COMMON            XI(3),H(196)
398  C*****XM,YM,ZM  ARE GEOMAGNETIC CARTESIAN INVERSE CO-ORDINATES            C*****XM,YM,ZM  ARE GEOMAGNETIC CARTESIAN INVERSE CO-ORDINATES          
# Line 445  C*****FORM SLOWLY VARYING EXPRESSIONS   Line 434  C*****FORM SLOWLY VARYING EXPRESSIONS  
434  C  C
435  C  C
436        SUBROUTINE FELDG(GLAT,GLON,ALT,BNORTH,BEAST,BDOWN,BABS)                  SUBROUTINE FELDG(GLAT,GLON,ALT,BNORTH,BEAST,BDOWN,BABS)          
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
437  C-------------------------------------------------------------------  C-------------------------------------------------------------------
438  C CALCULATES EARTH MAGNETIC FIELD FROM SPHERICAL HARMONICS MODEL  C CALCULATES EARTH MAGNETIC FIELD FROM SPHERICAL HARMONICS MODEL
439  C REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTRE, INTERNAL NOTE 61,  C REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTRE, INTERNAL NOTE 61,
# Line 489  C                 TO THE LOCAL GEODETIC Line 476  C                 TO THE LOCAL GEODETIC
476  C                 POINTING IN THE TANGENTIAL PLANE TO THE NORTH, EAST  C                 POINTING IN THE TANGENTIAL PLANE TO THE NORTH, EAST
477  C                 AND DOWNWARD.    C                 AND DOWNWARD.  
478  C-----------------------------------------------------------------------  C-----------------------------------------------------------------------
       REAL(8) G,H,X,Z,F,S,T,XI,Y,XXX,BXXX,BYYY,BZZZ,B  
       REAL(8) YYY,ZZZ,BABS,BEAST,BRHO,BNORTH,BDOWN,ST,CT,CP,SP  
       REAL(8) ERA, AQUAD, BQUAD,ALT,RHO,RQ,D  
479        DIMENSION         V(3),B(3),G(196)        DIMENSION         V(3),B(3),G(196)
480        CHARACTER*258      NAME        CHARACTER*258      NAME
481        INTEGER NMAX        INTEGER NMAX
482        REAL TIME        REAL TIME
483        COMMON            XI(3),H(196)        COMMON            XI(3),H(196)
         
484        COMMON/MODEL/     G,NMAX,TIME,NAME        COMMON/MODEL/     G,NMAX,TIME,NAME
485        SAVE/MODEL/        SAVE/MODEL/
486        COMMON/GENER/     ERA,AQUAD,BQUAD,UMR        COMMON/GENER/     UMR,ERA,AQUAD,BQUAD
487        SAVE/GENER/        SAVE/GENER/
488  C  C
489  C-- IS RECORDS ENTRY POINT  C-- IS RECORDS ENTRY POINT
# Line 583  c      print *,' I ',I Line 566  c      print *,' I ',I
566  C  C
567  C  C
568        SUBROUTINE FELDCOF(YEAR,DIMO)        SUBROUTINE FELDCOF(YEAR,DIMO)
       IMPLICIT REAL(8)(A-H)  
       IMPLICIT REAL(8)(O-Z)  
569  C------------------------------------------------------------------------  C------------------------------------------------------------------------
570  C     DETERMINES COEFFICIENTS AND DIPOL MOMENT FROM IGRF MODELS  C     DETERMINES COEFFICIENTS AND DIPOL MOMENT FROM IGRF MODELS
571  C      C    
# Line 601  C--------------------------------------- Line 582  C---------------------------------------
582        CHARACTER*258    FILMOD        CHARACTER*258    FILMOD
583  C     ### FILMOD, DTEMOD arrays +1  C     ### FILMOD, DTEMOD arrays +1
584  c     DIMENSION       GH1(144),GH2(120),GHA(144),FILMOD(14),DTEMOD(14)  c     DIMENSION       GH1(144),GH2(120),GHA(144),FILMOD(14),DTEMOD(14)
       REAL(8) GH1, GH2, GHA  
585        DIMENSION       GH1(196),GH2(196),GHA(196),FILMOD(3),DTEMOD(3)        DIMENSION       GH1(196),GH2(196),GHA(196),FILMOD(3),DTEMOD(3)
586        DOUBLE PRECISION X,F0,F        DOUBLE PRECISION X,F0,F
       DOUBLE PRECISION DIMO  
587        INTEGER L1,L2,L3        INTEGER L1,L2,L3
588        INTEGER NMAX        INTEGER NMAX
       REAL YEAR  
589        REAL TIME        REAL TIME
590        CHARACTER *258 P1,P2,P3        CHARACTER *258 P1,P2,P3
       REAL(8) AQUAD,BQUAD,ERAD  
591        COMMON/PPATH/ L1,L2,L3,P1, P2, P3        COMMON/PPATH/ L1,L2,L3,P1, P2, P3
592        SAVE/PPATH/        SAVE/PPATH/
593        COMMON/MODEL/   GH1,NMAX,TIME,FIL1        COMMON/MODEL/   GH1,NMAX,TIME,FIL1
594        SAVE/MODEL/        SAVE/MODEL/
595        COMMON/GENER/   ERAD,AQUAD,BQUAD,UMR        COMMON/GENER/   UMR,ERAD,AQUAD,BQUAD
596        SAVE/GENER/        SAVE/GENER/
597  C     ### updated to 2005  C     ### updated to 2005
598  C     CHARACTER COEFPATH*80, COEF1*80, COEF2*80, COEF3*80  C     CHARACTER COEFPATH*80, COEF1*80, COEF2*80, COEF3*80
# Line 700  C--   DETERMINE MAGNETIC DIPOL MOMENT AN Line 677  C--   DETERMINE MAGNETIC DIPOL MOMENT AN
677           F = GHA(J) * 1.D-5           F = GHA(J) * 1.D-5
678           F0 = F0 + F * F           F0 = F0 + F * F
679   1234 CONTINUE   1234 CONTINUE
680        DIMO = DSQRT(F0)        DIMO = REAL(DSQRT(F0))
681                
682        GH1(1) =  0.0        GH1(1) =  0.0
683        I=2                  I=2          
# Line 716  c      print *, "quq" Line 693  c      print *, "quq"
693           IF(IS.EQ.0) F0 = F0 * (2.D0 * X - 1.D0) / X           IF(IS.EQ.0) F0 = F0 * (2.D0 * X - 1.D0) / X
694           F = F0 * 0.5D0                                               F = F0 * 0.5D0                                    
695           IF(IS.EQ.0) F = F * SQRT2           IF(IS.EQ.0) F = F * SQRT2
696           GH1(I) = GHA(I-1) * F0           GH1(I) = GHA(I-1) * REAL(F0)
697           I = I+1                                                   I = I+1                                        
698           DO 9 M=1,N                                               DO 9 M=1,N                                    
699              F = F * (X + M) / (X - M + 1.D0)                              F = F * (X + M) / (X - M + 1.D0)                
700              IF(IS.EQ.0) F = F * DSQRT((X - M + 1.D0) / (X + M))              IF(IS.EQ.0) F = F * DSQRT((X - M + 1.D0) / (X + M))
701              GH1(I) = GHA(I-1) * F              GH1(I) = GHA(I-1) * REAL(F)
702              GH1(I+1) = GHA(I) * F              GH1(I+1) = GHA(I) * REAL(F)
703              I=I+2              I=I+2
704   9       CONTINUE                                             9       CONTINUE                                          
705        RETURN        RETURN
# Line 730  c      print *, "quq" Line 707  c      print *, "quq"
707  C      C    
708  C      C    
709        SUBROUTINE GETSHC (IU, FSPEC, NMAX, ERAD, GH, IER)                  SUBROUTINE GETSHC (IU, FSPEC, NMAX, ERAD, GH, IER)          
710        IMPLICIT REAL(8)(A-H)                                                                                  
       IMPLICIT REAL(8)(O-Z)  
711  C ===============================================================                C ===============================================================              
712  C                                                                                C                                                                              
713  C     Version 1.01                                                  C     Version 1.01                                                
# Line 760  C     Line 736  C    
736  C     ===============================================================                C     ===============================================================              
737                
738        CHARACTER  FSPEC*(*), FOUT*258        CHARACTER  FSPEC*(*), FOUT*258
       REAL(8) GH,ERAD  
739        DIMENSION       GH(*)                                                DIMENSION       GH(*)                                        
740  C     ---------------------------------------------------------------                C     ---------------------------------------------------------------              
741  C     Open coefficient file. Read past first header record.          C     Open coefficient file. Read past first header record.        
# Line 824  C Line 799  C
799  C  C
800          SUBROUTINE INTERSHC (DATE, DTE1, NMAX1, GH1, DTE2,                    SUBROUTINE INTERSHC (DATE, DTE1, NMAX1, GH1, DTE2,          
801       1                        NMAX2, GH2, NMAX, GH)                         1                        NMAX2, GH2, NMAX, GH)                  
802          IMPLICIT REAL(8)(A-H)                                                                                  
         IMPLICIT REAL(8)(O-Z)  
         REAL DATE  
803  C ===============================================================                C ===============================================================              
804  C                                                                                C                                                                              
805  C       Version 1.01                                                  C       Version 1.01                                                
# Line 854  C       USGS, MS 964, Box 25046 Federal Line 827  C       USGS, MS 964, Box 25046 Federal
827  C                                                                                C                                                                              
828  C ===============================================================                C ===============================================================              
829                                                                                                                                                                    
         REAL(8) GH1, GH2, GH  
830          DIMENSION       GH1(*), GH2(*), GH(*)                                  DIMENSION       GH1(*), GH2(*), GH(*)                        
831                                                                                                                                                                    
832  C ---------------------------------------------------------------                C ---------------------------------------------------------------              
# Line 894  C Line 866  C
866  C  C
867          SUBROUTINE EXTRASHC (DATE, DTE1, NMAX1, GH1, NMAX2,                    SUBROUTINE EXTRASHC (DATE, DTE1, NMAX1, GH1, NMAX2,          
868       1                        GH2, NMAX, GH)                                 1                        GH2, NMAX, GH)                          
         IMPLICIT REAL(8)(A-H)  
         IMPLICIT REAL(8)(O-Z)  
         REAL DATE  
869                                                                                                                                                                    
870  C ===============================================================                C ===============================================================              
871  C                                                                                C                                                                              
# Line 925  C       USGS, MS 964, Box 25046 Federal Line 894  C       USGS, MS 964, Box 25046 Federal
894  C                                                                                C                                                                              
895  C ===============================================================                C ===============================================================              
896                                                                                                                                                                    
         REAL(8) GH1, GH2, GH  
897          DIMENSION       GH1(*), GH2(*), GH(*)                                    DIMENSION       GH1(*), GH2(*), GH(*)                          
898                                                                                                                                                                    
899  C ---------------------------------------------------------------                C ---------------------------------------------------------------              
# Line 964  C -------------------------------------- Line 932  C --------------------------------------
932  C  C
933  C  C
934          SUBROUTINE INITIZE(TP1,TL1,TP2,TL2,TP3,TL3)          SUBROUTINE INITIZE(TP1,TL1,TP2,TL2,TP3,TL3)
         IMPLICIT REAL(8)(A-H)  
         IMPLICIT REAL(8)(O-Z)  
935  C----------------------------------------------------------------  C----------------------------------------------------------------
936  C Initializes the parameters in COMMON/GENER/  C Initializes the parameters in COMMON/GENER/
937  C  C
# Line 981  C ERA, EREQU and ERPOL as recommended by Line 947  C ERA, EREQU and ERPOL as recommended by
947  C ASTRONOMICAL UNION .  C ASTRONOMICAL UNION .
948  C-----------------------------------------------------------------  C-----------------------------------------------------------------
949          INTEGER TL1,TL2,TL3          INTEGER TL1,TL2,TL3
950          CHARACTER (len=258) TP1,TP2,TP3          CHARACTER (len=*) :: TP1,TP2,TP3
951          INTEGER L1,L2,L3          INTEGER L1,L2,L3
952          CHARACTER *258 P1,P2,P3          CHARACTER *258 P1,P2,P3
         REAL(8) AQUAD,BQUAD,ERA  
   
953          COMMON/PPATH/ L1,L2,L3,P1, P2, P3          COMMON/PPATH/ L1,L2,L3,P1, P2, P3
954          SAVE/PPATH/          SAVE/PPATH/
955    
956          COMMON/GENER/ERA,AQUAD,BQUAD,UMR          COMMON/GENER/UMR,ERA,AQUAD,BQUAD
957          SAVE/GENER/          SAVE/GENER/
958    
959          L1 = TL1          L1 = TL1
Legend:
Removed from v.1.8  
changed lines
  Added in v.1.10
  ViewVC Help
Powered by ViewVC 1.1.23