SUBROUTINE CONV_FOV_ATM_SUN( & nl, layers, layere, & appang, trueang, lockdown, tau, & fovdat, fov_elev, numfov, & sldc, el_sol, numsol, & sim_exo, conv_tau ) IMPLICIT NONE c save c c $Log: conv_fov_atm_sun.f,v $ c Revision 1.1 2007/06/26 19:48:59 deaver c Initial Checkin c c Revision 5.1 2000/01/18 21:25:30 deaver c Modified to handle calls when NUMFOV=0. Routine will now c compute Solar*tran at the lock down and normalize by sim_exo c which is the SLDC value at the exo atmospheric lockdown c c Revision 5.0 1998/08/31 14:21:58 deaver c Changed conv_tau and sim_exo to real*8. c c Revision 1.3 1997/08/25 14:52:41 deaver c Changed to 2nd order interpolation c c Revision 1.2 1996/09/20 16:33:17 deaver c Added return when numfov = 0 c c Revision 1.1 1994/02/24 01:36:20 deaver c Initial revision c c c description c this subroutine convolves the instrument FOV with the atmosphere c and the SLDC to derive a convolved Tran profile c c externals c liner Linear interpolation subroutine c intrinsics c real c constants C INCLUDE 'hal_src:haloretlib_parameters.inc' !VAX c INCLUDE 'haloretlib_parameters.inc' !IBM include 'f77parameters.inc' c input INTEGER*4 & nl, !Number of levels & layers, !Beginning level to calculate & layere, !Ending level to calculate & numfov, !Number of points in FOVDAT & numsol !Number of points in SLDC c & itran REAL*8 & appang(nl), !App zenith angle for each level (radians) & trueang(nl), !True zenith angle for each level (radians) & lockdown(nl), !Boresight lockdown position relative to the ! top edge of Sun for each level (radians) & fovdat(numfov), !Vertical FOV data & fov_elev(numfov), !FOV elevation (radians) & sldc(numsol), !Solar limb darkening curve & EL_SOL(numsol), !Position of each SLDC data point relative ! to the top edge (radians) & tau(nl), !Infintesimal transmission for each level & sim_exo !Simulated exo atmospheric signal ! Output REAL*8 & CONV_TAU(nl) !Transmission profile convolved with FOV and C Local variables ! the SLDC INTEGER*4 & I, ILEV !Loop variables real*8 & APP_TOP_EDGE, !App zenith angle of the top edge of Sun (radians) & TRUE_TOP_EDGE, !True zenith angle of the top edge of Sun (radians) & ZEN_FOV(MAXFOV), !App zenith angle for each FOV data point (radians) & TOTAL_SIG, !Result of FOV convolved with SLDC and TRAN & TRAN(MAXFOV), !Transmission at each ZEN_FOV data point c & appang2(ML), !Apparent angle of transmittance c & trueang2(ML), !True zenith angle for each level (radians) c & sldc2(MAXSOL), !Solar limb darkening curve c & EL_SOL2(MAXSOL), !Position of each SLDC data point relative & FOVPOS(MAXFOV), !Position of each FOV data point on the solar disk ! relative to the top edge. (radians) & SOLAR(MAXFOV) !SLDC value at each FOVPOS data point c character *80 interp_comment logical interp_error_flag cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(numfov .gt. maxfov) then write(*,*) "number of fov points exceed maxfov ", numfov, maxfov stop "error in conv_fov_atm_sun" endif c c do i=1,nl c appang2(i)=appang(i) c trueang2(i)=trueang(i) c enddo c c do i=1,numsol c el_sol2(i)=el_sol(i) c sldc2(i)=sldc(i) c enddo c if(numfov .eq. 0) then !Use the center value do ilev=layers,layere zen_fov(1)=APPANG(ILEV) !Center of FOV APP_TOP_EDGE=APPANG(ILEV)-LOCKDOWN(ILEV) call linerd(appang,trueang,app_top_edge, & true_top_edge,nl,1) !Determine True Top Edge call linerd(appang,trueang,zen_fov,fovpos,nl,1) FOVPOS(1)=FOVPOS(1)-TRUE_TOP_EDGE call linerd(el_sol,sldc,fovpos,solar,numsol,1) call interpolate_12d(zen_fov,tran,appang,tau(1), & 1, nl, 2, interp_error_flag, interp_comment) if(interp_error_flag) then print*, interp_comment stop "error in conv_atm_sun" endif CONV_TAU(ILEV)=solar(1)*tran(1)/sim_exo ! c if(itran.eq.2) then c call interpolate_12d(zen_fov,tran,appang2,tau(1,2), c & 1, nl, 2, interp_error_flag, interp_comment) c CONV_TAU(ILEV,2)=solar(1)*tran(1)/sim_exo c endif enddo else DO 100 ILEV=layers,layere ! c ZEN_FOV(1)=APPANG(ILEV)+FOVSTART DO 20 I=1,NUMFOV ZEN_FOV(I)=APPANG(ILEV)+ fov_elev(i) 20 CONTINUE ! APP_TOP_EDGE=APPANG(ILEV)-LOCKDOWN(ILEV) call linerd(appang,trueang,app_top_edge,true_top_edge, & nl,1) call linerd(appang,trueang,zen_fov,fovpos,nl,numfov) DO 30 I=1,NUMFOV FOVPOS(I)=FOVPOS(I)-TRUE_TOP_EDGE 30 CONTINUE call linerd(el_sol,sldc,fovpos,solar,numsol,numfov) ! call interpolate_12d(zen_fov,tran,appang,tau(1),numfov, & nl, 2, interp_error_flag, interp_comment) if(interp_error_flag) then print*, interp_comment stop "error in conv_atm_sun" endif c TOTAL_SIG=0.0D+00 DO 40 I=1,NUMFOV TOTAL_SIG=TOTAL_SIG+FOVDAT(I)*SOLAR(I)*TRAN(I) 40 CONTINUE CONV_TAU(ILEV)=TOTAL_SIG/sim_exo ! c if(itran.eq.2) then c call interpolate_12d(zen_fov,tran,appang2,tau(1,2),numfov, c & nl, 2, interp_error_flag, interp_comment) c TOTAL_SIG=0.0D+00 c DO 70 I=1,NUMFOV c TOTAL_SIG=TOTAL_SIG+FOVDAT(I)*SOLAR(I)*TRAN(I) c 70 CONTINUE c CONV_TAU(ILEV,2)=TOTAL_SIG/sim_exo c endif 100 CONTINUE endif ! RETURN END c subroutine interpolate_12d( x, y, xa, ya, nx, nxa, ido, # interp_error_flag, interp_comment ) C$Log: conv_fov_atm_sun.f,v $ CRevision 1.1 2007/06/26 19:48:59 deaver CInitial Checkin C c Revision 5.1 2000/01/18 21:25:30 deaver c Modified to handle calls when NUMFOV=0. Routine will now c compute Solar*tran at the lock down and normalize by sim_exo c which is the SLDC value at the exo atmospheric lockdown c c Revision 5.0 1998/08/31 14:21:58 deaver c Changed conv_tau and sim_exo to real*8. c c Revision 1.3 1997/08/25 14:52:41 deaver c Changed to 2nd order interpolation c c Revision 1.1 1995/10/03 15:36:05 thompson c Initial revision c C======================================================================C C C C SUBROUTINE : FD2_DOUBLE C C C C PURPOSE: C C C C THIS ROUTINE DOES A FIRST OR SECOND ORDER FINITE DIFFERENCE C C INTERPOLATION. THE VALUES IN XA MUST BE MONOTONICALLY C C INCREASING. THE INTERPOLATION IS CONTROLLED BY THE VALUE OF C C IDO. C C IDO = 1 ( FIRST ORDER ) C C IDO = 2 ( SECOND ORDER ) C C AN ERROR FLAG ( LOGICAL ) IS RETURNED WITH A VALUE OF TRUE C C ALONG WITH A COMMENT ( CHARACTER (80) ) IF ANY OF THE FOLLOWING C C CONDITIONS ARISE: C C 1. NUMBER OF POINTS IN XA AND YA IS LESS THEN C C TWO IF FIRST ORDER INTERPOLATION IS REQUESTED OR C C LESS THEN THREE IF SECOND ORDER INTERPOLATION C C IS REQUESTED. C C 2. THE FIRST POINT IN THE X ARRAY IS OUTSIDE THE C C FIRST XA VALUE ( EXTRAPOLATION NOT ALLOWED ). C C 3. THE LAST POINT IN THE X ARRAY IS OUTSIDE THE LAST C C POINT IN THE XA ARRAY ( EXTRAPOLATION NOT ALLOWED ). C C IF THE ERROR FLAG IS TRUE, THE CALLING PROGRAM SHOULD C C TERMINATE. C C C C C C PARAMETERS : C C C C INPUT C C X......"X" VALUE FOR WHICH YOU WANT A "Y" VALUE C C XA.....X ARRAY VALUES C C YA.....Y ARRAY VALUES C C IDO....FLAG FOR FIRST OR SECOND ORDER FLAG C C NX.....NUMBER OF ELEMENTS IN X AND Y ARRAY C C NXA....NUMBER OF ELEMENTS IN XA AND YA ARRAY C C OUTPUT C C Y......INTERPOLATED Y VALUE CORRESPONDING TO "X" C C INTERP_ERROR_FLAG...LOGICAL - TRUE IF ERROR OCCURRED C C INTERP_COMMENT......CHARACTER (80) STRING DESCRIBING C C ERROR C C C C EXTERNALS : C C C C SOURCE: EARL THOMPSON C C (GATS) C C C C C C ORIGINAL ROUTINE BY LARRY GORDLEY C C RECODED AND DOUBLE PRECISIONED BY EARL THOMPSON C C C C LANGUAGE: FORTRAN 5 C C C C DATE STARTED : APRIL 3, 1995 C C LATEST REVISION: APRIL 6, 1995 C C C C======================================================================C implicit none save integer nx, nxa, ido, i, j real *8 x(nx), y(nx), xa(nxa), ya(nxa) real *8 x0, x1, f10, f21, f210 character *80 interp_comment logical interp_error_flag interp_error_flag=.false. c check things if(nx.lt.2.and.ido.eq.1) then interp_error_flag=.true. interp_comment='interpolate_12d-not enough points ' else if(nxa.lt.3.and.ido.eq.2) then interp_error_flag=.true. interp_comment='interpolate_12d-not enough points ' c else if(x(1).lt.xa(1)) then c interp_error_flag=.true. c interp_comment='interpolate_12d-first point out of bounds' c else if(x(nx).gt.xa(nxa)) then c interp_error_flag=.true. c interp_comment= 'interpolate_12d-last point out of bounds' endif if(interp_error_flag) return c sort thru xa array c and find first point above c x value c do is over all points j=1 do 90 i=1,nx 5 continue if(x(i).gt.xa(j+1).and.j.lt.nxa-2) then j=j+1 go to 5 endif if(ido.eq.1.and.x(i).gt.xa(J+1)) j=j+1 x0=x(i)-xa(j) f10=(ya(j+1)-ya(j))/(xa(j+1)-xa(j)) y(i)=ya(j)+x0*f10 c return if 1st order if(ido.eq.1) go to 90 x1=x(i)-xa(j+1) f21=(ya(j+2)-ya(j+1))/(xa(j+2)-xa(j+1)) f210=(f21-f10)/(xa(j+2)-xa(j)) y(i)=y(i)+x0*x1*f210 90 continue return end