[Fortran] 纯文本查看 复制代码
SUBROUTINE ELECTX ELECTX01
C CALCULATES ELECTRON DENSITY AND GRADIENT FROM ACQUIRED ELECTX02
C PROFILES PERFORMING A POLINOMIAL INTERPOLATION ELECTX03
C ******************************************************************************
DIMENSION FN2C(600,10,25)
DIMENSION COE(4),XA(4),YA(4)
DIMENSION ALPHA(600),BETA(600),GAMMA(600)
C DIMENSION ALPHA(600),BETA(600),GAMMA(600),DELTA(600)
SAVE ALPHA,BETA,GAMMA
C SAVE ALPHA,BETA,GAMMA,DELTA
COMMON /ALEX2/ NOC,HPC(600),FNC(600,10,25) GPROF000
COMMON /ZZZZ/ ZZLAT,ZZLON,JLAT,JLON LATLON00
SAVE LATOLD,LONOLD LATLON00
C ******************************************************************************
C EQUIVALENCE (XMTRH,W(3)),(RCVRH,W(20)) ELECTX04
C ******************************************************************************
COMMON /CONST/ PI,PIT2,PID2,DEGS,RAD,K,C,LOGTEN ELECTX05
COMMON /XX/ MODX(2),X,PXPR,PXPTH,PXPPH,PXPT,HMAX ELECTX06
COMMON R(20),T,STP,DRDT(20),N2 ELECTX07
COMMON /WW/ ID,W0,W(400) ELECTX08
EQUIVALENCE (EARTHR,W(2)),(F,W(6)),(PVOLTA,W(100)),(PERT,W(150)) ELECTX09
C REAL K ELECTX10
C ******************************************************************************
F2=F*F ELECTX11
MODX(1)=4HGRID ELECTX12
IF(PVOLTA.EQ.0.) GO TO 32 ELECTX13
PVOLTA=0. ELECTX14
LATOLD=-1. ELECTX15
LONOLD=-1. ELECTX16
C ******************************************************************************
C ALEX: Lettura file 'GRIDPROFILES.txt',
C scrittura file 'GRIDPROFILES_TEST.txt',
C inizializzazione matrice per "plasma frequency profiles" FNC(K,J,I)
C ******************************************************************************
CALL GRIDPROFILES GPROF000
C ******************************************************************************
32 ZZLAT=DEGS*(PID2-R(2)) ELECTX17
ZZLON=DEGS*R(3) ELECTX18
CALL LATLON ELECTX19
IF(JLAT.EQ.LATOLD.AND.JLON.EQ.LONOLD) GO TO 33 ELECTX20
IF (JLAT.NE.LATOLD) LATOLD=JLAT ELECTX21
IF (JLON.NE.LONOLD) LONOLD=JLON ELECTX22
C ****** FIND A PARAMETER TO EXTRAPOLATE THE ELECTRONIC DENSITY *****ELECTX23
C ****** (BOTTOM PROFILE) NORMALIZE ITS VALUES TO OBTAIN X*F2 *****ELECTX24
C ****** FIND THE HEIGHT OF THE MAXIMUM ***************ELECTX25
C IF(FN2C(1,JLAT,JLON).NE.0.) GPROF000
C 1A=ALOG(FN2C(2,JLAT,JLON)/FN2C(1,JLAT,JLON))/(HPC(2)-HPC(1)) GPROF000
NMAX=1 ELECTX26
DO NH=1,NOC
C FN2C(NH,JLAT,JLON)=K*FN2C(NH,JLAT,JLON) GPROF000
FN2C(NH,JLAT,JLON)=FNC(NH,JLAT,JLON)**2 GPROF000
IF (FNC(NH,JLAT,JLON).GT.FNC(NMAX,JLAT,JLON)) NMAX=NH GPROF000
IF (NH.EQ.NOC) GO TO 4
ENDDO
C*******************************************************************************
C POLINOMIAL INTERPOLATION IN THE INTERVAL OF VALUES FN2C
C*******************************************************************************
4 DO 10 I=1,NOC-3
DO 22 MP=1,4
XA(MP)=HPC(I+MP-1) GPROF000
C YA(MP)=FN2C(I+MP-1) GPROF000
C ******************************************************************************
YA(MP)=FN2C(I+MP-1,JLAT,JLON) GPROF000
C ******************************************************************************
22 CONTINUE
CALL POLCOE (XA,YA,3,COE)
C CALL POLCOE (XA,YA,4,COE)
ALPHA(I)=COE(1)
BETA(I)=COE(2)
GAMMA(I)=COE(3)
C DELTA(I)=COE(4)
C WRITE(6,1707)I,ALPHA(I),BETA(I),GAMMA(I),DELTA(I)
C 1707 FORMAT (1X,I4,4(2X,E20.10))
10 CONTINUE
C ******************************************************************************
HMAX=HPC(NMAX) ELECTX27
33 H=R(1)-EARTHR ELECTX28
PXPR=0. ELECTX29
IF (H.GE.HPC(1)) GO TO 12 ELECTX30
X=0. ELECTX31
C IF(FN2C(1,JLAT,JLON).EQ.0.) GO TO 50 GPROF000
C X=FN2C(1,JLAT,JLON)*EXP(A*(H-HPC(1)))/F2 GPROF000
C PXPR=A*X ELECTX32
GO TO 50 ELECTX33
12 IF (H.GE.HPC(NOC)) GO TO 18 ELECTX34
NH=2 ELECTX35
NSTEP=1 ELECTX36
IF (H.LT.HPC(NH-1)) NSTEP=-1 ELECTX37
15 IF (HPC(NH-1).LE.H.AND.H.LT.HPC(NH)) GO TO 16 ELECTX38
NH=NH+NSTEP ELECTX39
GO TO 15 ELECTX40
C ******************************************************************************
C LINEAR INTERPOLATION IN THE INTERVAL FN2C(K-1,J,I) AND FN2C(K,J,I)
C ******************************************************************************
C 16 X=(ALPHA(NH-1)+BETA(NH-1)*H)/F2
C PXPR=(BETA(NH-1))/F2
C ******************************************************************************
C POLINOMIAL INTERPOLATION IN THE INTERVAL FN2C(K-1,J,I) AND FN2C(K,J,I)
C ******************************************************************************
16 X=(ALPHA(NH-1)+BETA(NH-1)*H+GAMMA(NH-1)*H**2)/F2
PXPR=(BETA(NH-1)+H*(2.*GAMMA(NH-1)))/F2
C 16 X=(ALPHA(NH-1)+BETA(NH-1)*H+GAMMA(NH-1)*H**2+DELTA(NH-1)*H**3)/F2
C PXPR=(BETA(NH-1)+H*(2.*GAMMA(NH-1))+H**2*(3.*DELTA(NH-1)))/F2
C ******************************************************************************
GO TO 50 ELECTX41
18 X=FN2C(NOC,JLAT,JLON)/F2 GPROF000
50 IF (PERT.NE.0.) CALL ELECT1 ELECTX42
C IF (X.EQ.0..AND.H.GE.RCVRH) PRINT 1234, R(1),R(2),R(3) ELECTX43
IF (X.EQ.0.) PRINT 1234, R(1),R(2),R(3) AZZ
C*******************************************************************************
1234 FORMAT (3(2X,F20.10)) ELECTX44
WRITE(6,1704) R(1),R(2),R(3),R(4),R(5),R(6) ELECTX45
1704 FORMAT (6(2X,F20.10)) ELECTX46
RETURN ELECTX47
END
F 币
贡献
权杖
窥视卡
发表于 2023-1-3 18:00:25
微信
收藏
点赞
点踩
提升卡
置顶卡
变色卡
千斤顶
显身卡
楼主
发表于 2023-1-10 22:09:28