├── docker ├── readme.md └── Dockerfile ├── Makefile ├── README ├── SRC ├── erfc.f ├── thermal_oly.f └── meshg_oly.f ├── meshin_oly └── LICENSE /docker/readme.md: -------------------------------------------------------------------------------- 1 | This container hosts a built version of plasti. 2 | 3 | docker run -it --rm -v $HOME/plasti:/home/plasti_user/work geodynamics/plasti 4 | 5 | This command will start the plasti docker image and give you terminal access. Any changes made in the /home/plasti/work directory will be reflected on the host machine at home/plasti. 6 | -------------------------------------------------------------------------------- /docker/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu:jammy 2 | 3 | RUN apt-get update && \ 4 | DEBIAN_FRONTEND='noninteractive' \ 5 | DEBCONF_NONINTERACTIVE_SEEN='true' \ 6 | apt-get install --yes \ 7 | build-essential \ 8 | git \ 9 | gfortran \ 10 | liblapack-dev \ 11 | libopenblas-dev 12 | 13 | RUN useradd \ 14 | --create-home \ 15 | plasti_user 16 | 17 | USER plasti_user 18 | 19 | WORKDIR /home/plasti_user 20 | 21 | RUN git clone 'https://github.com/geodynamics/plasti'; cd plasti; make FORT="gfortran -fallow-argument-mismatch"; 22 | 23 | ENV PATH="/home/plasti_user/ellipsis3d:${PATH}" 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | ## compilers 3 | 4 | # gfortran 5 | FORT = gfortran 6 | F90FLAGS = -O3 7 | 8 | # g95 9 | #FORT = g95 10 | #F90FLAGS = -O3 -fsloppy-char 11 | 12 | # Absoft (untested) 13 | #FORT = f90 14 | #F90FLAGS = -s -O3 -YEXT_NAMES=LCS -YEXT_SFX=_ -Z156 -N113 -N11 15 | 16 | ## libraries 17 | LIBS = -llapack -lblas 18 | 19 | all: plasti_oly meshg_oly 20 | 21 | ##### 22 | ##### PLASTI 23 | ##### 24 | ## object files to link (includes any header and module files) 25 | PLAS_OBJS = SRC/plasti_oly.o SRC/thermal_oly.o 26 | ## Link all files into main program 27 | plasti_oly: $(PLAS_OBJS) 28 | $(FORT) $(LINKFLAGS) $(PLAS_OBJS) -o plasti_oly $(LIBS) 29 | ## compile object files 30 | SRC/plasti_oly.o: SRC/plasti_oly.f 31 | $(FORT) $(F90FLAGS) -c SRC/plasti_oly.f -o SRC/plasti_oly.o 32 | SRC/thermal_oly.o: SRC/thermal_oly.f 33 | $(FORT) $(F90FLAGS) -c SRC/thermal_oly.f -o SRC/thermal_oly.o 34 | 35 | ## clean 36 | clean: 37 | rm -f $(PLAS_OBJS) *.mod $(MESH_OBJS) $(PLAS2DX_OBJS) plasti_oly meshg_oly 38 | 39 | ##### 40 | ##### MESHG 41 | ##### 42 | ## object files to link 43 | MESH_OBJS = SRC/meshg_oly.o SRC/erfc.o 44 | ## Link files into main program 45 | meshg_oly: $(MESH_OBJS) 46 | $(FORT) $(LINKFLAGS) $(MESH_OBJS) -o meshg_oly 47 | ## compile object files 48 | SRC/meshg_oly.o: SRC/meshg_oly.f 49 | $(FORT) $(F90FLAGS) -c -o SRC/meshg_oly.o SRC/meshg_oly.f 50 | SRC/erfc.o: SRC/erfc.f 51 | $(FORT) $(F90FLAGS) -c -o SRC/erfc.o SRC/erfc.f 52 | 53 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Plasti is a 2-D ALE (Arbitrary Lagrangian Eulerian) code donated to 2 | CIG by Sean Willett and Chris Fuller of the University of 3 | Washington. The code was based on work by Philippe Fullsack at 4 | Dalhousie University in Canada. 5 | 6 | The code is described in greater detail in the paper 7 | 8 | Fuller, C.W., Willett, S.D. and Brandon, M.T., 2006. Formation of 9 | forearc basins and their influence on subduction zone 10 | earthquakes. Geology, 34: 65-68. 11 | 12 | To compile Plasti, you need a Fortran 90 compiler and lapack and blas 13 | implementations. The code has been tested with gfortran (4.0 and 4.1) 14 | and g95, and was originally developed with the Absoft compiler. 15 | 16 | The makefile is set up to compile with gfortran, so you may have to 17 | modify it if you want to use a different compiler. gfortan gives a 18 | number of warnings about common blocks, but should compile fine. 19 | 20 | Included with the code is a sample input file "meshin_oly". The file 21 | has extensive comments. When plasti reads the input file, it expects 22 | the comment lines interspersed with the input parameters. So do not 23 | increase or decrease the number of lines of comments. Also, the input 24 | file must be named "meshin_oly". 25 | 26 | To get results, first run meshg_oly to create the mesh and then 27 | plasti_oly to actually run the simulation. So if you are using 28 | gfortran, the entire sequence of commands would be 29 | 30 | $ make 31 | $ ./meshg_oly 32 | $ ./plasti_oly 33 | 34 | meshg_oly will create some files in the input/ and profiles/ 35 | directories. It should complete in a few seconds. plasti_oly will 36 | create files in the output/ directory. It should finish the first 37 | step in less than a minute, but the entire run will take hours. The 38 | code outputs every 100 time steps, and it should take about ten minutes 39 | to get to step 100. 40 | 41 | If, for example, you wish to look at the xx component of the stress as 42 | a function of the coordinates, coord_1, coord_2, coord_3, etc. has the 43 | coordinates for that time step, and stress_xx_1 has the stress at 44 | those coordinates. 45 | 46 | Please report bugs by opening an issue on the geodynamics/plasti repository. 47 | 48 | Questions about the software should be directed to the CIG forum located here: 49 | https://community.geodynamics.org/ 50 | 51 | Enjoy! 52 | -------------------------------------------------------------------------------- /SRC/erfc.f: -------------------------------------------------------------------------------- 1 | C Copyright (C) 1995-2006 Sean Willett, Chris Fuller 2 | 3 | C This program is free software; you can redistribute it and/or modify 4 | C it under the terms of the GNU General Public License as published by 5 | C the Free Software Foundation; either version 2 of the License, or (at 6 | C your option) any later version. 7 | 8 | C This program is distributed in the hope that it will be useful, but 9 | C WITHOUT ANY WARRANTY; without even the implied warranty of 10 | C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 11 | C General Public License for more details. 12 | 13 | C You should have received a copy of the GNU General Public License 14 | C along with this program; if not, write to the Free Software 15 | C Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 16 | C USA 17 | 18 | FUNCTION erfc(x) 19 | REAL erfc,x 20 | CU USES gammp,gammq 21 | REAL gammp,gammq 22 | if(x.lt.0.)then 23 | erfc=1.+gammp(.5,x**2) 24 | else 25 | erfc=gammq(.5,x**2) 26 | endif 27 | return 28 | END 29 | 30 | 31 | FUNCTION gammp(a,x) 32 | REAL a,gammp,x 33 | CU USES gcf,gser 34 | REAL gammcf,gamser,gln 35 | if(x.lt.0..or.a.le.0.)pause 'bad arguments in gammp' 36 | if(x.lt.a+1.)then 37 | call gser(gamser,a,x,gln) 38 | gammp=gamser 39 | else 40 | call gcf(gammcf,a,x,gln) 41 | gammp=1.-gammcf 42 | endif 43 | return 44 | END 45 | 46 | FUNCTION gammq(a,x) 47 | REAL a,gammq,x 48 | CU USES gcf,gser 49 | REAL gammcf,gamser,gln 50 | if(x.lt.0..or.a.le.0.)pause 'bad arguments in gammq' 51 | if(x.lt.a+1.)then 52 | call gser(gamser,a,x,gln) 53 | gammq=1.-gamser 54 | else 55 | call gcf(gammcf,a,x,gln) 56 | gammq=gammcf 57 | endif 58 | return 59 | END 60 | 61 | SUBROUTINE gcf(gammcf,a,x,gln) 62 | INTEGER ITMAX 63 | REAL a,gammcf,gln,x,EPS,FPMIN 64 | PARAMETER (ITMAX=100,EPS=3.e-7,FPMIN=1.e-30) 65 | CU USES gammln 66 | INTEGER i 67 | REAL an,b,c,d,del,h,gammln 68 | gln=gammln(a) 69 | b=x+1.-a 70 | c=1./FPMIN 71 | d=1./b 72 | h=d 73 | do 11 i=1,ITMAX 74 | an=-i*(i-a) 75 | b=b+2. 76 | d=an*d+b 77 | if(abs(d).lt.FPMIN)d=FPMIN 78 | c=b+an/c 79 | if(abs(c).lt.FPMIN)c=FPMIN 80 | d=1./d 81 | del=d*c 82 | h=h*del 83 | if(abs(del-1.).lt.EPS)goto 1 84 | 11 continue 85 | pause 'a too large, ITMAX too small in gcf' 86 | 1 gammcf=exp(-x+a*log(x)-gln)*h 87 | return 88 | END 89 | 90 | SUBROUTINE gser(gamser,a,x,gln) 91 | INTEGER ITMAX 92 | REAL a,gamser,gln,x,EPS 93 | PARAMETER (ITMAX=100,EPS=3.e-7) 94 | CU USES gammln 95 | INTEGER n 96 | REAL ap,del,sum,gammln 97 | gln=gammln(a) 98 | if(x.le.0.)then 99 | if(x.lt.0.)pause 'x < 0 in gser' 100 | gamser=0. 101 | return 102 | endif 103 | ap=a 104 | sum=1./a 105 | del=sum 106 | do 11 n=1,ITMAX 107 | ap=ap+1. 108 | del=del*x/ap 109 | sum=sum+del 110 | if(abs(del).lt.abs(sum)*EPS)goto 1 111 | 11 continue 112 | pause 'a too large, ITMAX too small in gser' 113 | 1 gamser=sum*exp(-x+a*log(x)-gln) 114 | return 115 | END 116 | 117 | FUNCTION gammln(xx) 118 | REAL gammln,xx 119 | INTEGER j 120 | DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) 121 | SAVE cof,stp 122 | DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, 123 | *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, 124 | *-.5395239384953d-5,2.5066282746310005d0/ 125 | x=xx 126 | y=x 127 | tmp=x+5.5d0 128 | tmp=(x+0.5d0)*log(tmp)-tmp 129 | ser=1.000000000190015d0 130 | do 11 j=1,6 131 | y=y+1.d0 132 | ser=ser+cof(j)/y 133 | 11 continue 134 | gammln=tmp+log(stp*ser/x) 135 | return 136 | END 137 | 138 | -------------------------------------------------------------------------------- /meshin_oly: -------------------------------------------------------------------------------- 1 | #output flag (1=all ouput for plasti, 0=profiles only for flexure) 2 | 1 3 | #input flag (1=allow files for dens, x node pos, init thickness, 0=use meshin) 4 | 0 5 | #Total num col 6 | 200 7 | # num of eulerian rows in mechanical 8 | # num rows in thermal model is set by the x spacing 9 | 25 10 | # lagrangian mesh parameters (scaling factors: >1.0 stretch, <1.0 compress) 11 | # (extent past pro side, extent past retro side, extent past base, 12 | # node density compred to eulerian mesh) 13 | 1.00e+00 0.70e+00 1.10e+00 0.95e+00 14 | #Singularity Point, defined by pos (1) or node (0) (set, pos) CAN ONLY USE NODE DEF SINCE VELOCITY BCS NEED TO KNOW WHERE THE SPOINT IS 15 | 0 1.00e+02 16 | #Initial Thickness on pro-side (mech,sub lithos,asthenos) (m) 17 | 0.25e+04 3.00e+04 9.00e+04 18 | #Initial Thickness on retro-side (lithos) (m) 19 | # mech thick is the thick of pro crust at spoint 20 | 5.10e+04 21 | #Relative dif in height of the uncompensated mech. base 22 | # for pro and reto sides. Set pro value at 0.0 and 23 | # retro value at desired difference 24 | 0.00e+00 2.00e+04 25 | #Water depth defined by distance above pro model edge and 26 | # tolerance for water flexure iterataion 27 | 0.00e+03 1.00e+03 28 | # x padding beyond model boundaries for flexure problem. 29 | # simulates an infinite plate when loads extend to model 30 | # boundaries (number of nodes, distance) 31 | # in the meshg, all ref to node # does NOT include the 32 | # nodes from the padding 33 | 400 1.00e+06 34 | #horizontal spacing for nodes 35 | # num of linearly spaced segments 36 | 5 37 | # spacing (num nodes, beg, end) (#s do not include the padding) 38 | 25 0.00e+00 1.70e+05 39 | 20 1.73e+05 2.20e+05 40 | 110 2.21e+05 3.50e+05 41 | 30 3.52e+05 4.80e+05 42 | 15 4.85e+05 5.50e+05 43 | # model extent relative to coastline(coast is at x=0) 44 | # this is by mk_init_prof.f when making the mech bndry array 45 | # from the obs. profiles for the olympics 46 | -2.50e+05 2.50e+05 47 | #deviation from initial thickness of the crust 48 | # num sets 49 | 24 50 | # pos change defined by node(0) or x-position(1), beg, slope. 51 | 1 1.20e+05 2.50e-02 52 | 1 1.40e+05 0.00e+00 53 | 1 1.40e+05 6.00e-02 54 | 1 1.65e+05 0.00e+00 55 | 1 1.65e+05 1.10e-01 56 | 1 2.00e+05 0.00e+00 57 | 1 2.00e+05 1.75e-01 58 | 1 2.20e+05 0.00e+00 59 | 1 2.20e+05 2.10e-01 60 | 1 2.40e+05 0.00e+00 61 | 1 2.40e+05 2.50e-01 62 | 1 2.60e+05 0.00e+00 63 | 1 2.60e+05 3.00e-01 64 | 1 2.75e+05 0.00e+00 65 | 1 2.75e+05 3.10e-01 66 | 1 2.85e+05 0.00e+00 67 | 1 2.85e+05 -0.25e+00 68 | 1 2.95e+05 0.00e+00 69 | 1 2.95e+05 -0.20e-00 70 | 1 3.05e+05 0.00e+00 71 | 1 3.05e+05 -0.14e-00 72 | 1 3.15e+05 0.00e+00 73 | 1 3.15e+05 -0.05e-00 74 | 1 3.30e+05 0.00e+00 75 | #isostatic compensation:local(0),one plate(1),two plate(2) 76 | 2 77 | #initial profile: loaded plates(0), prescribed circular arcs w/ dip (1) 78 | 1 79 | #for prescribed geometry: 80 | # dip of sub plate (deg) 81 | 2.50e+01 82 | # trench location (node), ie where to begin dip arc 83 | # input type (1=x-pos, 0=node #), pos or node 84 | 1 1.20e+05 85 | #flexural rigidity for making plate profiles (pro-plate, retro-plate) 86 | 9.50e+25 1.00e+24 87 | #flexural rigidity for isostaic calc (pro-plate, retro-plate) 88 | 2.40e+20 2.40e+20 89 | #subduction end load (Pa) 90 | 1.00e+00 91 | #subduction end moment 92 | 0.00e+00 93 | # shift in cooupling point (m)(neg. -> deeper, pos -> higher) 94 | 0.00e+03 95 | #length of pro-plate past s-point for sub load (m) 96 | # NOTE: Currently you must have a non-zero extension. w/o any extension 97 | # there is no way to get the slope of the descending plate. this could be 98 | # changed so that in the event of no extension, a subduction angle could 99 | # be prescribed 100 | 1.90e+05 101 | #Plasti extension flag 102 | # since the extension is not used to update the position of the slab 103 | # past s in plasti, this option(=1) will chop the pro-plate at the 104 | # s-point when it is output for plasti 105 | 1 106 | #tolerance for position of plates in coupling at s-point 107 | 5.0 108 | #Velocities for Pro-Lith, underplating normal vel (m/my) 109 | 5.00e+04 0.00e+00 110 | #unplate flag (2=x position, 0=node loaction) 111 | # flag, node location, x position 112 | 2 80 2.00e+05 113 | #Variable Material Properties for mech model: Cohesion,int angle frict,density 114 | # min viscosity(vmin),activation energy(Q),pre-exponential(A),power-law expn(n) 115 | # number of sets listed below 116 | 1 117 | #defined for elements, start at bot. 118 | # beg col, end col, beg row, end row, coh, phi, dens, vmin, Q, A, n) 119 | 1 199 1 24 1.00e+03 2.00e+01 2.80e+03 0.15e+02 0.45e+06 2.55e-17 2.20e+00 120 | #Number of elem boundary layers for model top and base 121 | # boundary layers remain a constant thickness for all time. 122 | # Boundary layer thickness can be defined by an even spacing of all 123 | # elements over the pro side thickness (=0), or a thickness defined over 124 | # all of the boundary elements set here (=1) 125 | # ##NOTE##: if setting variable phi on base, should set these elements as 126 | # boundary layers 127 | #upper boundary layer:# of elements,even spacing(=0) or defined (=1),thickness(m) 128 | 2 0 0.00e+03 129 | #lower boundary layer:# of elements,even spacing(=0) or defined (=1),thickness(m) 130 | 2 0 0.00e+03 131 | #Variable therm prop. for mech domain. 132 | # These will replace in the mech domain what is defined below for whole model 133 | # NOTE: bounds should probbaly match those given above. defined for a 134 | # quad, ie two triangular elements 135 | # number of sets (always have at least 1,can leave same as domain def) 136 | 1 137 | # beg col,end col,beg row,end row,therm cond(x,y),density,spec heat,heat prod 138 | 1 199 1 24 2.00e+00 2.00e+00 2.80e+03 1.00e+03 1.25e-06 139 | #Rigid viscosity (vrig) 140 | 0.40e+11 141 | #Compressibility (beta) 142 | 0.10e-14 143 | #flag to use linear or non-linear eqns (1=linear) 144 | 2 145 | #Purely Plastic def(1 for plastic)(must have linear visc for plastic) 146 | 0 147 | #epsinv (initial strain rate invarient)= 148 | 0.1 149 | # maximum temperature used in calc. pre. exponential for linear viscous case 150 | 12.73e+02 151 | #Densities (overlying fluid/sea level, mantle) 152 | # NOTE: this mantle density is used in the flexure/isostacy calculation. 153 | # even if there are defined density variations in the thermal model (as 154 | # can be defined below) this value will be used for the flexure problem. 155 | 1.03e+03 3.30e+03 156 | #Num BCs (fixed x,y vel on edges, fixed tan vel on edges, pressure, 157 | # loaded sides,tangent vel) 158 | 0 50 0 0 200 159 | #Num t-steps,output int all, output int lagrangian temp,t-step length (my) 160 | 2000 100 50 0.50e-02 161 | #min iter, max iter, num filtering passes, convergence tolerance 162 | 3 550 2 1.00e+02 163 | #erosion parameters (erosl,erosr,peros,rpow) 164 | 0.00e+00 0.00e+00 0.00e+00 2.00e+00 165 | # sedimentation parameters (allow sed (yes=1),allow sed of bounding basins, 166 | # L bound of sed, R bound of sed, max fill for bounding basins) 167 | # 168 | 0 0 20 145 3.00e+01 169 | # basin tracking parameters (flag for tracking 1=yes, tstep interval for 170 | # marking of basin surfaces, initial length of tracking array, init length 171 | # of index aray) 172 | 0 50 9000 500 173 | # maximum slope value: any surface slope greater than this is lowered to 174 | # prevent surface nodes from having runaway velocties 175 | 0.40e+00 176 | #Thermal runup parameters (num tsteps, tstep length) 177 | 00 0.25e+00 178 | #Variable Thermal properties: 179 | # aniso. therm. cond (x,y??), desity, spec. heat, heat prod. 180 | # defined for 5 domains:(1)mech,(2)pro-lith,(3)retro-lith 181 | # (4)pro-athen,(5)retro-athen 182 | 2.00e+00 2.00e+00 2.80e+03 1.00e+03 1.00e-06 183 | 2.00e+00 2.00e+00 2.80e+03 1.00e+03 0.00e+00 184 | 2.00e+00 2.00e+00 2.80e+03 1.00e+03 0.00e+00 185 | 50.00e+00 50.00e+00 2.80e+03 1.00e+03 0.00e+00 186 | 50.00e+00 50.00e+00 2.80e+03 1.00e+03 0.00e+00 187 | #Thermal BCs 188 | # previously applied over a defined set of nodes. with new mesh, don't know 189 | # how many nodes there are in thermal code till later, so just define the temp 190 | # for the surface and model base temp. NOTE: base temp is only applied in 191 | # asthenosphere, end of sub. lithos does not have temp or flux bc. Also, 192 | # at this point flux bcs have not been implemented 193 | #(surface temp, base temp) 194 | 2.73e+02 15.73e+02 195 | #Cooling Oceanic Lithosphere BC for pro-side 196 | # NOTE: uses spec heat and conductiv. from lithosphere, ignores heat prod, 197 | # should be used with some amount of thermal runup 198 | # 1=on,0=off; age (my); 199 | 0 1.00e+00 200 | #Mech BCs 201 | # sets 202 | # num of bcs, start node, increment, value 203 | 0 204 | 0 205 | 0 206 | 2 207 | 25 1 1 50000. 208 | 25 4976 1 00000. 209 | 5 210 | 96 1 25 50000. 211 | 1 2401 25 37500. 212 | 1 2426 25 25000. 213 | 1 2451 25 12500. 214 | 101 2476 25 00000.00 215 | 0 216 | 0 217 | ## 218 | ## Output file flags (1 to output, 0 to not output) 219 | ## 220 | #number of possible output files 221 | 60 222 | # coords of nodes (1) 223 | coord 1 224 | # velocity of mechanical model at nodes (2) 225 | vel 1 226 | # pressure at eulerian elements (3) 227 | press 0 228 | # stresses and stuff (4-10) 229 | stress_xx 1 230 | stress_yy 1 231 | stress_xy 1 232 | stress_zz 1 233 | stress_secinv 1 234 | stress_yield 1 235 | stress_flag 1 236 | # strain rates (directions and invarients), dilitation (11-16) 237 | srate_xx 1 238 | srate_yy 0 239 | srate_xy 1 240 | srate_zz 0 241 | srate_dilt 0 242 | srate_secinv 1 243 | # coords of lagrangian mesh (17) 244 | lmesh 1 245 | # temp for crust(eulerian elems) (18) 246 | temp_mech 1 247 | # viscosity (19-20) 248 | visc_elem 1 249 | visc_gp 0 250 | # erosion at the surface (nodes) (21) 251 | erosion 0 252 | # temp at lagrangian nodes (22) 253 | temp_track 0 254 | # underplating velocity at base (nodes) (23) 255 | unvel 0 256 | # exhumation rate lagrangian (nodes) (24) 257 | exhum 0 258 | # valley, mean and ridge surface profiles (nodes) (25) 259 | sur_prof 0 260 | # flag (yes/no) for ductile def at lagrangian nodes (26) 261 | duc_flag 0 262 | # material props at elements (27-33) 263 | matp_phi 1 264 | matp_den 0 265 | matp_coh 0 266 | matp_prex 0 267 | matp_vmin 0 268 | matp_activ 0 269 | matp_expon 0 270 | # amount of material filled into basins with closed basin catch (34) 271 | basinfill 1 272 | # amount of material lost with max slope catch (35) 273 | peakchop 1 274 | # tracking of basin surfaces (36) 275 | basin_track 1 276 | # temp of lagrangian nodes, can be output more often than other output (37) 277 | l_temp_all 0 278 | # coords of thermal model (38) 279 | coordt 1 280 | # vel of thermal model (reduced resolution) (39) 281 | velthermal_alt 0 282 | # vel of thermal model, all (40) 283 | velthermal 0 284 | # temp of entire model (41) 285 | temp 1 286 | # thermal props (42-44) 287 | matp_hprod 1 288 | matp_tcond_y 0 289 | matp_spec_ht 0 290 | -------------------------------------------------------------------------------- /SRC/thermal_oly.f: -------------------------------------------------------------------------------- 1 | c SUBROUTINE THERMAL (a derivative of the 2 | c program heatran) 3 | 4 | C Copyright (C) 1995-2006 Sean Willett, Chris Fuller 5 | 6 | C This program is free software; you can redistribute it and/or modify 7 | C it under the terms of the GNU General Public License as published by 8 | C the Free Software Foundation; either version 2 of the License, or (at 9 | C your option) any later version. 10 | 11 | C This program is distributed in the hope that it will be useful, but 12 | C WITHOUT ANY WARRANTY; without even the implied warranty of 13 | C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | C General Public License for more details. 15 | 16 | C You should have received a copy of the GNU General Public License 17 | C along with this program; if not, write to the Free Software 18 | C Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | C USA 20 | 21 | c#CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 22 | c 23 | c ne = Total number of elements 24 | c nn = total number of nodes 25 | c n = total number of boundary nodes? 26 | c 27 | c coordcoordcoordt,Z, coordinates 28 | c nodet(ne,j) - J=1,2,3 Node numbers for the Ith element 29 | c J=4 Propery Map Value 30 | c J=5 Velocity Domain 31 | c 32 | c vx(ne) - velocity in x-dir 33 | c vz(ne) - velocity in z-dir 34 | c velx(nn) - velocity in x-dir from plasti 35 | c vely(nn) - velocity in z-dir from plasti 36 | c asf(ne,3) - shape function A coefficents 37 | c bsf(ne,3) - shape function B coefficents 38 | c area(ne) - Areas of elements 39 | c tcond(2,ne) - Rock thermal conductivities (anisotropic) 40 | c trho(ne) - Rock densities 41 | c spheat(ne) - Rock specific heats 42 | c hprod(ne) - Heat production 43 | c tempt(nn) - Temperatures 44 | c temp(ne/2) - Temperatures averaged over quad elements 45 | c told(nn) - Temperatures at previous time step 46 | c ntbnd(n) - Constant temperature nodes 47 | c btem(n) - Constant temperature values 48 | c neflux(n,2) - Constant heat flux element and nodes on that side 49 | c =(1,2, and/or 3) 50 | c flux(n) - Constant heat flux value 51 | c iter - Iteration number 52 | c itst - Time step number 53 | c#cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 54 | 55 | subroutine thermal(deltt,itst,nn,ne,nout,nrowp,nrow,ncol, 56 | *lda,lbw,ntbn,ioutpt) 57 | 58 | use dyn_arrays 59 | use dyn_arrays_therm 60 | implicit real*8 (a-h,o-z) 61 | implicit integer (i-n) 62 | character date*10,time*10,time2*10 63 | integer quadcount 64 | 65 | c ALLOCATE LOCAL ARRAY STORAGE 66 | allocate(a(lda,nn),asf(ne,3),bsf(ne,3),area(ne),ipt(nn)) 67 | allocate(rhst(nn)) 68 | 69 | call date_and_time(date,time) 70 | print*,'Real Time Entering Thermal is: ',time 71 | print*,'Time Step Number =',itst 72 | print*,'Delt = ',deltt 73 | deltt=(3.15578e13)*deltt 74 | 75 | c first (0) interation sets up initial conditions 76 | if(itst.eq.0) then 77 | vx=0.0 78 | vz=0.0 79 | endif 80 | 81 | c SET UP SHAPE FUNCTION COEFFICIENTS 82 | call sfcoef(nn,ne,itst) 83 | 84 | c ASSEMBLE GLOBAL STIFFNESS MATRIX FOR HEAT TRANSPORT PROBLEM 85 | call globet(ne,nn,lbw,lda,deltt,itst) 86 | 87 | c APPLY BOUNDARY CONDITIONS 88 | c NOTE: flux bcs are not implemented in the platis meshg, 89 | c so set nfel == to 0 here 90 | nfel=0 91 | call bct(nn,ne,ntbn,nfel,lda,lbw) 92 | 93 | c SOLVE SYSTEM OF EQUATIONS (LAPAK ROUTINES) 94 | call dgbtrf(nn,nn,lbw,lbw,a,lda,ipt,info) 95 | if(info.ne.0) then 96 | print*,'##### ERROR IN FACTORIZATION, THERMAL DGBTRF' 97 | print*,'info from dgbtrf',info 98 | call outputt(nn,ne,itst,nout,nrow,ncol,ioutpt) 99 | stop 100 | endif 101 | call dgbtrs('N',nn,lbw,lbw,1,a,lda,ipt,rhst,nn,info) 102 | if(info.ne.0) then 103 | print*,'##### ERROR IN FACTORIZATION, THERMAL DGBTRS' 104 | print*,'info from dgbtrs',info 105 | call outputt(nn,ne,itst,nout,nrow,ncol,ioutpt) 106 | stop 107 | endif 108 | 109 | c STORE NEW TEMPERATURES 110 | do i=1,nn 111 | tempt(i)=rhst(i) 112 | end do 113 | 114 | c OUTPUT RESULTS AFTER CONVERGENCE OR SPECIFIED NUMBER OF ITERATIONS 115 | call outputt(nn,ne,itst,nout,nrow,ncol,ioutpt) 116 | 117 | c AVERAGE TEMP OVER QUAD-ELEMENTS 118 | quadcount=0 119 | k=0 120 | do j=2*(nrow-nrowp),ne,2*(nrow-1) 121 | do i=1,2*(nrowp-1),2 122 | k=i+j 123 | quadcount=quadcount+1 124 | temp(quadcount)=(tempt(nodet(k,1))+tempt(nodet(k,2))+ 125 | * tempt(nodet((k+1),1))+tempt(nodet((k+1),3))) 126 | temp(quadcount)=temp(quadcount)/4 127 | end do 128 | end do 129 | 130 | call date_and_time(date,time2) 131 | print*,'Real Time Leaving Thermal is: ',time2 132 | deallocate(a,asf,bsf,area,ipt,rhst) 133 | return 134 | end 135 | c ###################################################################### 136 | c ###################################################################### 137 | c************************************************************ 138 | c* SUBROUTINE TO OUTPUT RESULTS * 139 | c************************************************************ 140 | subroutine outputt(nn,ne,itst,nout,nrow,ncol,ioutpt) 141 | 142 | use dyn_arrays 143 | use dyn_arrays_therm 144 | implicit real*8 (a-h,o-z) 145 | implicit integer (i-n) 146 | integer thdpl,fstpl,secpl,temp1 147 | character(30):: coordt_op='coordt_',veltherm_alt_op= 148 | *'velthermal_alt_',velthermal_op='velthermal_',temp_op='temp_', 149 | *matp_hprod_op='matp_hprod_',matp_tcond_y_op='matp_tcond_y_', 150 | *matp_spec_ht_op='matp_spec_ht_',dir,fextn 151 | character(10):: nums='0123456789' 152 | 153 | if(itst.eq.99999)return 154 | if(itst.eq.0)return 155 | if(itst.eq.1) goto 39 156 | if(nout.eq.1) goto 39 157 | c catch for no output to equilibrate thermal model to subduction 158 | itest=mod(itst,nout) 159 | if(itest.ne.0)return 160 | 39 continue 161 | c print*,' Inside Thermal Output, Timestep=',itst 162 | 163 | c output directory 164 | dir='output/' 165 | c determine extension for output file names 166 | if(ioutpt.lt.10) then 167 | fextn=nums(ioutpt+1:ioutpt+1) 168 | elseif(ioutpt.lt.100) then 169 | fstpl=(ioutpt)/10+1 170 | secpl=(ioutpt-10*(fstpl-1))+1 171 | fextn=nums(fstpl:fstpl)//nums(secpl:secpl) 172 | elseif(ioutpt.lt.1000) then 173 | fstpl=(ioutpt)/100+1 174 | temp1=(ioutpt-(ioutpt/100)*100) 175 | secpl=temp1/10+1 176 | thdpl=ioutpt-((fstpl-1)*100+(secpl-1)*10)+1 177 | if(temp1.lt.10)secpl=1 178 | fextn=nums(fstpl:fstpl)//nums(secpl:secpl)// 179 | * nums(thdpl:thdpl) 180 | endif 181 | 182 | c############# 183 | c coords 184 | c############# 185 | if(output_flags(38).eq.1) then 186 | open(19,file=trim(dir)//trim(coordt_op)//trim(fextn), 187 | * position='rewind') 188 | write(19,101)nn 189 | do i=1,nn 190 | write(19,105)coordt(1,i),coordt(2,i) 191 | end do 192 | close(19) 193 | endif 194 | 195 | c############# 196 | c reduced resolution thermal vel 197 | c############# 198 | if(output_flags(39).eq.1) then 199 | open(14,file=trim(dir)//trim(veltherm_alt_op)//trim(fextn), 200 | * position='rewind') 201 | write(14,104)ne/2,ncol,nrow 202 | do i=1,ne,2 203 | write(14,103)vx(i)*3.15578e13 204 | end do 205 | do i=1,ne,2 206 | write(14,103)vz(i)*3.15578e13 207 | end do 208 | close(14) 209 | endif 210 | 211 | c############ 212 | c full resolution velocities 213 | c############ 214 | if(output_flags(40).eq.1) then 215 | open(16,file=trim(dir)//trim(velthermal_op)//trim(fextn), 216 | * position='rewind') 217 | write(16,101)ne,ncol,nrow 218 | do i=1,ne 219 | write(16,103)vx(i)*3.15578e13 220 | end do 221 | do i=1,ne 222 | write(16,103)vz(i)*3.15578e13 223 | 224 | end do 225 | close(16) 226 | endif 227 | 228 | c############# 229 | c temp 230 | c############# 231 | if(output_flags(41).eq.1) then 232 | open(18,file=trim(dir)//trim(temp_op)//trim(fextn), 233 | * position='rewind') 234 | write(18,101) nn 235 | do i=1,nn,8 236 | count=(nn-i)/8 237 | if(count.ge.1) then 238 | j=i+7 239 | else 240 | j=nn 241 | endif 242 | write(18,102)(tempt(k)-273,k=i,j) 243 | end do 244 | close(18) 245 | endif 246 | 247 | c############# 248 | c thermal material props 249 | c############# 250 | c heat production 251 | if(output_flags(42).eq.1) then 252 | open(21,file=trim(dir)//trim(matp_hprod_op)//trim(fextn), 253 | * position='rewind') 254 | write(21,101)ne 255 | do i=1,ne 256 | write(21,103)hprod(i) 257 | end do 258 | close(21) 259 | endif 260 | c thermal cond y-dir 261 | if(output_flags(43).eq.1) then 262 | open(21,file=trim(dir)//trim(matp_tcond_y_op)//trim(fextn), 263 | * position='rewind') 264 | write(21,101)ne 265 | do i=1,ne 266 | write(21,103)tcond(2,i) 267 | end do 268 | close(21) 269 | endif 270 | c specific heat 271 | if(output_flags(44).eq.1) then 272 | open(21,file=trim(dir)//trim(matp_spec_ht_op)//trim(fextn), 273 | * position='rewind') 274 | write(21,101)ne 275 | do i=1,ne 276 | write(21,103)spheat(i) 277 | end do 278 | close(21) 279 | endif 280 | 281 | 101 format(i6) 282 | 102 format(13f12.2) 283 | 103 format(2e15.9) 284 | 104 format(3i6) 285 | 105 format(SP,6e12.6,/5e12.6) 286 | return 287 | end 288 | 289 | c******************************************************************** 290 | c* SUBROUTINE TO APPLY BOUNDARY CONDITIONS * 291 | c******************************************************************** 292 | subroutine bct(nn,ne,ntbn,nfel,lda,lbw) 293 | 294 | use dyn_arrays 295 | use dyn_arrays_therm 296 | implicit real*8 (a-h,o-z) 297 | implicit integer (i-n) 298 | 299 | c print*,'nfel=',nfel,'ntbn=',ntbn 300 | c print*,'lda=',lda,'lbw=',lbw 301 | m=2*lbw+1 302 | 303 | c apply constant flux bc 304 | if(nfel.gt.0) then 305 | do in=1,nfel 306 | n1=neflux(in,1) 307 | n2=neflux(in,2) 308 | c find length of element side 309 | xl=(coordt(1,n1)-coordt(1,n2))**2 310 | yl=(coordt(2,n1)-coordt(2,n2))**2 311 | tl=dsqrt(xl+yl) 312 | c calculate nodal value and insert in rhs 313 | fln=flux(in)*tl/2.000000 314 | rhst(n1)=fln+rhst(n1) 315 | rhst(n2)=fln+rhst(n2) 316 | end do 317 | endif 318 | 319 | c apply constant value boundary condition 320 | if(ntbn.eq.0) go to 301 321 | do in=1,ntbn 322 | ib=ntbnd(in) 323 | llb=ib-lbw 324 | iub=ib+lbw 325 | if(llb.lt.1)llb=1 326 | if(iub.gt.nn)iub=nn 327 | c set corresponding row of global stiffness matrix to 0 328 | do jb=llb,iub 329 | kb=ib-jb+m 330 | a(kb,jb)=0.0 331 | end do 332 | c set principle diagonal component to 1. 333 | c and rhs to prescribed value 334 | a(m,ib)=1.00000 335 | rhst(ib)=btem(in) 336 | end do 337 | 301 continue 338 | 339 | return 340 | end 341 | c************************************************************** 342 | c* ROUTINE TO ASSEMBLE GLOBAL STIFFNESS MATRIX AND RHS * 343 | c* FOR HEAT TRANSPORT EQUATION * 344 | c************************************************************** 345 | subroutine globet(ne,nn,lbw,lda,deltt,itst) 346 | 347 | use dyn_arrays_therm 348 | use dyn_arrays 349 | implicit real*8 (a-h,o-z) 350 | implicit integer (i-n) 351 | real*8 massk,massb 352 | Dimension massb(3),massk(3,3), 353 | *t(3),s(3,3) 354 | 355 | c initialize stiffness matrix and rhs 356 | 357 | mbw=2*lbw+1 358 | ma=(3*lbw+1) 359 | do j=1,nn 360 | rhst(j)=0.0 361 | do i=1,ma 362 | a(i,j)=0.0 363 | end do 364 | end do 365 | 366 | c loop over each element 367 | c calculate element stiffness matrix 368 | do 100 iele=1,ne 369 | c conductivity for the element 370 | c dispersion tensor 371 | dxx=tcond(1,iele) 372 | dzz=tcond(2,iele) 373 | dxz=0.0 374 | 375 | c assemble element stiffness matrix 376 | do jj=1,3 377 | aj=asf(iele,jj) 378 | bj=bsf(iele,jj) 379 | massb(jj)=hprod(iele)*area(iele)/3.0d0 380 | term2=trho(iele)*spheat(iele)*(vx(iele)*aj+ 381 | * vz(iele)*bj)/6.0000 382 | do ii=1,3 383 | ai=asf(iele,ii) 384 | bi=bsf(iele,ii) 385 | massk(ii,jj)=(dxx*ai*aj+dxz*(ai*bj+bi*aj)+dzz*bi*bj)/(4.* 386 | * area(iele))+term2 387 | end do 388 | end do 389 | 390 | c Calculate Transient Component To E.S.M. and RHS 391 | 392 | c Define density and specific heat for the rock 393 | if(itst.eq.0) goto 31 394 | denr=trho(iele) 395 | spec=spheat(iele) 396 | 397 | c Calculate bulk volume specific heat for the element 398 | bhc=denr*spec 399 | 400 | c Define nodal temperatures 401 | do ii=1,3 402 | t(ii)=told(nodet(iele,ii)) 403 | end do 404 | 405 | c Define Transient Mass (s) Matrix 406 | 407 | do 15 ii=1,3 408 | do 110 jj=1,3 409 | s(ii,jj)=bhc*area(iele)/12 410 | 110 continue 411 | s(ii,ii)=s(ii,ii)*2 412 | 15 continue 413 | 414 | c Insert into ESM(element stiffness matrix) and RHS 415 | 416 | do 30 ii=1,3 417 | do 20 jj=1,3 418 | massb(ii)=massb(ii)+s(ii,jj)*t(jj)/deltt 419 | massk(ii,jj)=massk(ii,jj)+s(ii,jj)/deltt 420 | 20 continue 421 | 30 continue 422 | 31 continue 423 | 424 | c assemble global stiffness matrix and rhs 425 | 426 | do 41 l=1,3 427 | i=nodet(iele,l) 428 | rhst(i)=rhst(i)-massb(l) 429 | do 40 m=1,3 430 | j=nodet(iele,m) 431 | k=i-j+mbw 432 | a(k,j)=a(k,j)-massk(l,m) 433 | 40 continue 434 | 41 continue 435 | 100 continue 436 | 437 | return 438 | end 439 | 440 | 441 | 442 | c**************************************************************** 443 | c* SUBROUTINE TO SET UP SHAPE FUNCTION COEFFICIENTS * 444 | c* FOR EACH ELEMENT * 445 | c**************************************************************** 446 | subroutine sfcoef(nn,ne,itst) 447 | 448 | use dyn_arrays_therm 449 | use dyn_arrays 450 | implicit real*8 (a-h,o-z) 451 | implicit integer (i-n) 452 | do ie=1,ne 453 | asf(ie,1)=coordt(2,nodet(ie,2))-coordt(2,nodet(ie,3)) 454 | asf(ie,2)=coordt(2,nodet(ie,3))-coordt(2,nodet(ie,1)) 455 | asf(ie,3)=coordt(2,nodet(ie,1))-coordt(2,nodet(ie,2)) 456 | bsf(ie,1)=coordt(1,nodet(ie,3))-coordt(1,nodet(ie,2)) 457 | bsf(ie,2)=coordt(1,nodet(ie,1))-coordt(1,nodet(ie,3)) 458 | bsf(ie,3)=coordt(1,nodet(ie,2))-coordt(1,nodet(ie,1)) 459 | area(ie)=(asf(ie,1)*bsf(ie,2)-bsf(ie,1)*asf(ie,2))/2.0000 460 | area(ie)=dabs(area(ie)) 461 | end do 462 | return 463 | end 464 | 465 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc. 5 | 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Library General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License 307 | along with this program; if not, write to the Free Software 308 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 309 | 310 | 311 | Also add information on how to contact you by electronic and paper mail. 312 | 313 | If the program is interactive, make it output a short notice like this 314 | when it starts in an interactive mode: 315 | 316 | Gnomovision version 69, Copyright (C) year name of author 317 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 318 | This is free software, and you are welcome to redistribute it 319 | under certain conditions; type `show c' for details. 320 | 321 | The hypothetical commands `show w' and `show c' should show the appropriate 322 | parts of the General Public License. Of course, the commands you use may 323 | be called something other than `show w' and `show c'; they could even be 324 | mouse-clicks or menu items--whatever suits your program. 325 | 326 | You should also get your employer (if you work as a programmer) or your 327 | school, if any, to sign a "copyright disclaimer" for the program, if 328 | necessary. Here is a sample; alter the names: 329 | 330 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 331 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 332 | 333 | , 1 April 1989 334 | Ty Coon, President of Vice 335 | 336 | This General Public License does not permit incorporating your program into 337 | proprietary programs. If your program is a subroutine library, you may 338 | consider it more useful to permit linking proprietary applications with the 339 | library. If this is what you want to do, use the GNU Library General 340 | Public License instead of this License. 341 | -------------------------------------------------------------------------------- /SRC/meshg_oly.f: -------------------------------------------------------------------------------- 1 | c mesh generator and parameter input for thermal and mechanical mesh 2 | c used in plasti 3 | c 4 | 5 | C Copyright (C) 1995-2006 Sean Willett, Chris Fuller 6 | 7 | C This program is free software; you can redistribute it and/or modify 8 | C it under the terms of the GNU General Public License as published by 9 | C the Free Software Foundation; either version 2 of the License, or (at 10 | C your option) any later version. 11 | 12 | C This program is distributed in the hope that it will be useful, but 13 | C WITHOUT ANY WARRANTY; without even the implied warranty of 14 | C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | C General Public License for more details. 16 | 17 | C You should have received a copy of the GNU General Public License 18 | C along with this program; if not, write to the Free Software 19 | C Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 20 | C USA 21 | 22 | c#################################################################### 23 | c define arrays that will be dynamically allocated in subroutines 24 | module dyn_arrays 25 | real(kind=8),allocatable::ypltop(:),xpl(:),yplbase(:),yrlbase(:), 26 | *xrlbase(:),xltemp(:),ranode(:,:),ymtop(:),yltemp(:),xmbase(:), 27 | *coh(:),slen1(:),slen2(:),fnode1(:),dyinit1(:),dyinit2(:), 28 | *fnode2(:),bc(:,:),dyinit(:),xp1(:),xp2(:),yp1(:),phi(:), 29 | *panode(:,:),rhoc(:),yp2(:),ymbase(:),rlnode(:,:),xbase(:), 30 | *cmnode(:,:),plnode(:,:),pos(:,:),therm_prop(:,:),thermbcs(:,:), 31 | *tm_prop(:,:),therm_cond(:,:),therm_rho(:),heat_prod(:), 32 | *spec_heat(:),dencol(:),therm_bc(:,:),vmin(:),q(:),prex(:), 33 | *expn(:) 34 | integer,allocatable::domain(:),ndomain(:),mecht_nodes(:), 35 | *plithb_nodes(:),plitht_nodes(:),mechb_nodes(:),rlithb_nodes(:), 36 | *output_flags(:) 37 | end module dyn_arrays 38 | c end of definitions 39 | c#################################################################### 40 | 41 | use dyn_arrays 42 | implicit real*8 (a-h,o-z) 43 | implicit integer (i-n) 44 | 45 | c read in input file 46 | 47 | call input(ncol,nerowm,nstype,sing, 48 | *pmthick,plthick,athick,rlthick,ypmbase,yrmbase,wdepth, 49 | *wtoler,npad,xpad,prigp,rrigp,prigi,rrigi,sload,smomen,xadd,ctoler, 50 | *plvel,upvel,iunflag,iunbeg,xunbeg,vrig, 51 | *beta,epsinv,rhof,rhom,numvebn,numpbn,numsid,numvtbn, 52 | *ntst,intout,intoutl,delt,minint,maxint,npass,toler,erosl, 53 | *erosr,peros,rpow,ntt2,deltt2,iso,ntmchg,plscale,rlscale,blscale, 54 | *dfact,slpmax,tmax,numvetbn,ioutflag,inflag,dyc,linflag,sdip, 55 | *ipflag,itrench,iplasflg,iblay,iblayt,isedl,isedr,iexflg, 56 | *ibasflg,nbastary,nbastind,intmrkb,ipkfill,ibasfill,sedmax,iflgcl, 57 | *agecl,iflgblt,iflgbl,tblayt,tblay,noutput) 58 | 59 | c find the spoint (used spoint is defined by position instead of node 60 | call find_node(nsing,nstype,sing,ncol,npad,xsing) 61 | print*,'s-point (desired, node, location): ',sing,nsing,xsing 62 | 63 | C Make model outlines/boundaries 64 | if(iso.ne.2) then 65 | print*,'######### STOP!!! ############' 66 | print*,'## Only have two plate case ##' 67 | print*,'## implemented, cannot do only ##' 68 | print*,'## one plate. ##' 69 | print*,'#################################' 70 | stop 71 | endif 72 | if(iso.eq.2) then 73 | c make x,y array for each plate 74 | call mk_plates(ncol,npad,xsing,xadd,np1,nsing,nsing1,np2) 75 | if(ipflag.eq.0) then 76 | c calculate flexural profile 77 | call calc_flex(nerowm,ncol,np1,np2,prigi,rrigi,rhom, 78 | * npad,nsing,nsing1,ctoler,sload,smomen,wdepth,wtoler,rhof, 79 | * ypmbase,yrmbase,wheight,inflag,dyc) 80 | elseif(ipflag.eq.1) then 81 | call arc_prof(nerowm,ncol,np1,np2,prigp,rrigp,rhom, 82 | * npad,nsing,nsing1,wdepth,ypmbase,yrmbase,wheight, 83 | * inflag,dyc,itrench,sdip) 84 | endif 85 | c output flexural profiles of just the two plates 86 | call profdump(xbase,yp1,yp2,np1,np2,nsing,npad) 87 | c make arrays of flexure profile for model (mech and sub lithos) 88 | call mech_bndry(ncol,nsing1,nsing,np1,npad,np2,plthick, 89 | * athick,yshift) 90 | endif 91 | c make lithosphere domain boundaries 92 | call lith_bndry(nsing1,nsing,plthick,athick,ncol,npltop,plvel, 93 | *nplbase,rlthick,irlbeg,nrlbase) 94 | c output the domain boundaries for plotting 95 | call bndry_output(wheight,ncol,npad,wdepth,np1,np2,yshift 96 | *,nsing,nsing1,npltop,nrlbase,nplbase) 97 | 98 | c only make and output mesh if desired 99 | if(ioutflag.eq.1) then 100 | c make nodes in mech model 101 | call mk_cmnodes(ncol,nerowm,iblay,iblayt,iflgblt,iflgbl, 102 | * tblayt,tblay) 103 | c make nodes in pro lithosphere 104 | call mk_plnodes(npltop,nplbase,nplrow,base) 105 | c make nodes in retro lithos 106 | call mk_rlnodes(nsing,nrlrow,irlbeg,ncol) 107 | c make nodes in retro asthenosphere 108 | call mk_ranodes(nrlrow,nsing,npltop,nrarow,ncol,base, 109 | * irlbeg,irabeg) 110 | c make nodes in pro-asthenosphere 111 | call mk_panodes(nplbase,nsing,nparow,base) 112 | c make array of all nodes 113 | call mk_node_array(nerowm,nrowl,nrowa,nplrow,nalrow, 114 | * ncol,ntrow,nplbase,nsing,nparow,irabeg,npltop) 115 | c make arrays of thermal properties and BCs 116 | call mk_therm_para(ntrow,ncol,ntmchg,nrowl,nrowa,ntbcs, 117 | * iflgcl,agecl,nplbase,npltop) 118 | c output parameters and mesh 119 | call output(ncol,nerowm,ntrow,nsing,plvel,upvel, 120 | * iunflag,iunbeg,vrig,beta,epsinv,rhof, 121 | * rhom,iso,prigi,rrigi,sload,smomen,xadd,ctoler,wdepth,wtoler, 122 | * numvebn,numpbn,numsid,numvtbn,ntst,delt,intout,intoutl,minint, 123 | * maxint,npass,toler,erosl,erosr,peros,rpow,ntt2,deltt2,np1,np2, 124 | * nsing1,npad,nplbase,npltop,plscale,rlscale,blscale,dfact,slpmax, 125 | * tmax,nrowl,plthick,numvetbn,linflag,iplasflg,iblay,iblayt,isedl, 126 | * isedr,iexflg,ibasflg,nbastary,nbastind,intmrkb,ipkfill,ibasfill, 127 | * sedmax,ntbcs,noutput) 128 | 129 | deallocate(panode,xmbase,xbase,coh,phi,rhoc,bc,xp1,yp1,xp2,yp2, 130 | * dyinit,yrlbase,xrlbase,xpl,ypltop,yplbase,ymtop,ymbase,xltemp, 131 | * yltemp,rlnode,plnode,cmnode,ranode,pos,dyinit1,dyinit2,domain, 132 | * ndomain,thermbcs,tm_prop,therm_cond,therm_rho,spec_heat, 133 | * heat_prod,vmin,q,prex,expn) 134 | endif 135 | 136 | end 137 | c######################################################## 138 | c############### END OF MAIN PROGRAM #################### 139 | c######################################################## 140 | 141 | 142 | c######################################################## 143 | c make array of all nodes in mesh 144 | c######################################################## 145 | subroutine mk_node_array(nerowm,nrowl,nrowa,nplrow, 146 | *nalrow,ncol,ntrow,nplbase,nsing,nparow,irabeg,npltop) 147 | use dyn_arrays 148 | implicit real*8 (a-h,o-z) 149 | implicit integer (i-n) 150 | integer plitht(200) 151 | c allocate space for the storage of node numbers of domain boundaries 152 | c used in output and used in plasti2dx to make boundaries 153 | c for dx plotting 154 | allocate(mecht_nodes(ncol),plithb_nodes(nplbase), 155 | *plitht_nodes(npltop),mechb_nodes(ncol), 156 | *rlithb_nodes(ncol-nsing)) 157 | 158 | c initialize indicies for the above arrays 159 | c top of mech model 160 | imtnode=0 161 | c base of pro lith 162 | iplbnode=0 163 | c top of pro lith 164 | ipltnode=0 165 | c base of retro lith 166 | irlbnode=0 167 | c top of retro lith 168 | imbnode=0 169 | 170 | c define number of rows/nodes in mesh 171 | c number of rows on pro lith side (-1 since top node is in mech) 172 | nrowl=nplrow-1 173 | c number of rows in pro asthen (-1 since top node is in lith) 174 | nrowa=nparow-1 175 | c total number of rows 176 | ntrow=nerowm+nrowl+nrowa 177 | allocate(pos(ntrow*ncol,2)) 178 | c array for element domain defs 179 | allocate(domain((ntrow)*(ncol))) 180 | allocate(ndomain((ntrow-1)*(ncol-1)*2)) 181 | c indicies for domains 182 | idomain=0 183 | index=0 184 | indexap=0 185 | indexlp=0 186 | indexm=0 187 | c these start at 1 since corner node is not counted in the domain 188 | indexlr=1 189 | indexar=1 190 | 191 | c########################################################## 192 | c Determine which sub geometry this is 193 | c icase 1: pro-asthen ends at spoint 194 | c icase 2: pro-asthen ends before the spoint 195 | c icase : pro-asthen ends after the spoint 196 | c 3: pro-asthen ends after retro-asthen begins 197 | c 4: pro-asthen ends when retro-asthen begins 198 | c 5: pro-asthen ends after retro-lith begins 199 | c 6: pro-asthen ends 1 colm before retro-asthen begins 200 | c########################################################## 201 | icase=0 202 | if(nplbase.eq.nsing) then 203 | icase=1 204 | else if(nsing.gt.nplbase) then 205 | icase=2 206 | else if(nsing.lt.nplbase) then 207 | if(irabeg.eq.nplbase) then 208 | icase=4 209 | else if(irabeg.eq.nplbase-1) then 210 | icase=6 211 | else if(irabeg.lt.nplbase-1) then 212 | icase=3 213 | else if(irabeg.gt.nplbase) then 214 | icase=5 215 | endif 216 | endif 217 | if(icase.eq.0) then 218 | print*,'##################################' 219 | print*,'## ERROR: Case not determined ##' 220 | print*,'##################################' 221 | endif 222 | 223 | c#################################################### 224 | c always begin with meshing to spoint (except case=1) 225 | c loop to/including the spoint 226 | c#################################################### 227 | 228 | c allow for a change in the number of rows (1=yes, 0=no) 229 | itog_ap=0; itog_lp=0; itog_lr=0; itog_ar=0; 230 | c starting value 231 | nshiftap=0; nshiftlp=0; nshiftar=0; nshiftlr=0; 232 | c include these domains (yes=1, no=0) 233 | iapon=1; ilpon=1; iaron=0; ilron=0; 234 | call mk_array(1,nrowa,iapon,1,nrowl,ilpon,1,nerowm,0,0, 235 | *iaron,1,0,ilron,1,nsing,nshiftap,nshiftlp,nshiftar,nshiftlr, 236 | *index,indexap,indexlp,indexm,indexar,indexlr,itog_ap,itog_lp, 237 | *itog_ar,itog_lr,idomain,imtnode,iplbnode,ipltnode,irlbnode, 238 | *imbnode) 239 | if(icase.eq.5) then 240 | c############# 241 | c Case 5 242 | c############# 243 | c loop from spoint+1 to final node of pro-astheno 244 | nshiftap=0; nshiftlp=0; nshiftar=0; nshiftlr=0; 245 | itog_ap=1; itog_lp=0; itog_ar=0; itog_lr=1; 246 | iapon=1; ilpon=1; iaron=0; ilron=1; 247 | index2=index 248 | call mk_array(1,nrowa,iapon,1,nrowl,ilpon,1,nerowm,0,0, 249 | * iaron,1,0,ilron,nsing+1,nplbase-1,nshiftap,nshiftlp,nshiftar, 250 | * nshiftlr, 251 | * index,indexap,indexlp,indexm,indexar,indexlr,itog_ap,itog_lp, 252 | * itog_ar,itog_lr,idomain,imtnode,iplbnode,ipltnode,irlbnode, 253 | * imbnode) 254 | c loop till/including beg of retro-astheno 255 | nshiftlr=nshiftlr; nshiftap=0; nshiftlp=0; nshiftar=0; 256 | itog_ap=0; itog_lp=1; itog_lr=1; itog_ar=0; 257 | iapon=0; ilpon=1; iaron=0; ilron=1; 258 | call mk_array(0,0,iapon,1,nrowl+1,ilpon,1,nerowm,0,0, 259 | * iaron,1,0,ilron,nplbase,irabeg,nshiftap,nshiftlp,nshiftar, 260 | * nshiftlr, 261 | * index,indexap,indexlp,indexm,indexar,indexlr,itog_ap,itog_lp, 262 | * itog_ar,itog_lr,idomain,imtnode,iplbnode,ipltnode,irlbnode, 263 | * imbnode) 264 | c loop till/including end of pro-lith 265 | nrowlr=nshiftlr; 266 | nshiftlr=0; nshiftap=0; nshiftlp=nshiftlp; nshiftar=0; 267 | itog_ap=0; itog_lp=1; itog_lr=0; itog_ar=1; 268 | iapon=0; ilpon=1; iaron=1; ilron=1; 269 | call mk_array(0,0,iapon,1,nrowl+1,ilpon,1,nerowm,1,0, 270 | * iaron,1,nrowlr,ilron,irabeg+1,npltop-1,nshiftap,nshiftlp, 271 | * nshiftar,nshiftlr, 272 | * index,indexap,indexlp,indexm,indexar,indexlr,itog_ap,itog_lp, 273 | * itog_ar,itog_lr,idomain,imtnode,iplbnode,ipltnode,irlbnode, 274 | * imbnode); 275 | nrowar=nshiftar+1; 276 | else if(icase.eq.3) then 277 | c############# 278 | c Case 3 279 | c############# 280 | c loop till the beg of retro-asthen 281 | nshiftlr=0; nshiftap=0; nshiftlp=0; nshiftar=0; 282 | itog_ap=1; itog_lp=0; itog_lr=1; itog_ar=0; 283 | iapon=1; ilpon=1; iaron=0; ilron=1; 284 | call mk_array(1,nrowa,iapon,1,nrowl,ilpon,1,nerowm,0,0, 285 | * iaron,1,0,ilron,nsing+1,irabeg,nshiftap,nshiftlp,nshiftar, 286 | * nshiftlr, 287 | * index,indexap,indexlp,indexm,indexar,indexlr,itog_ap,itog_lp, 288 | * itog_ar,itog_lr,idomain,imtnode,iplbnode,ipltnode,irlbnode, 289 | * imbnode); 290 | c loop till end of pro-asthen 291 | nrowlr=nshiftap; 292 | nshiftlr=0; nshiftap=nshiftap; nshiftlp=0; nshiftar=0; 293 | itog_ap=1; itog_lp=0; itog_lr=0; itog_ar=1; 294 | iapon=1; ilpon=1; iaron=1; ilron=1; 295 | call mk_array(1,nrowa,iapon,1,nrowl,ilpon,1,nerowm,1,0, 296 | * iaron,1,nrowlr,ilron,irabeg+1,nplbase-1,nshiftap,nshiftlp, 297 | * nshiftar,nshiftlr, 298 | * index,indexap,indexlp,indexm,indexar,indexlr,itog_ap,itog_lp, 299 | * itog_ar,itog_lr,idomain,imtnode,iplbnode,ipltnode,irlbnode, 300 | * imbnode); 301 | c loop till end of pro-lith 302 | c temp # rows in retro-astthen 303 | nartemp=nshiftar; 304 | nshiftlr=0; nshiftap=0; nshiftlp=0; nshiftar=0; 305 | itog_ap=0; itog_lp=1; itog_lr=0; itog_ar=1; 306 | iapon=0; ilpon=1; iaron=1; ilron=1; 307 | call mk_array(0,0,iapon,1,nrowl+1,ilpon,1,nerowm,1,nartemp, 308 | * iaron,1,nrowlr,ilron,nplbase,npltop-1,nshiftap,nshiftlp, 309 | * nshiftar,nshiftlr, 310 | * index,indexap,indexlp,indexm,indexar,indexlr,itog_ap,itog_lp, 311 | * itog_ar,itog_lr,idomain,imtnode,iplbnode,ipltnode,irlbnode, 312 | * imbnode); 313 | nrowar=nartemp+1+nshiftar; 314 | else if(icase.eq.1) then 315 | print*,'####################################################' 316 | print*,'####################################################' 317 | print*,'CASE 1: this is not implemented. the pro-asthen ' 318 | print*,' ends where the retro-lith ends. change the ' 319 | print*,' lith thickness or increase the mesh density ' 320 | print*,'####################################################' 321 | else if(icase.eq.2) then 322 | print*,'####################################################' 323 | print*,'####################################################' 324 | print*,'CASE 2: this is not implemented. the pro-asthen ' 325 | print*,' ends before the spoint. are you sure the ' 326 | print*,' orogen dimensions are reasonable ' 327 | print*,'####################################################' 328 | else if(icase.eq.6) then 329 | print*,'####################################################' 330 | print*,'####################################################' 331 | print*,'CASE 6: this is not implemented. see notes for ' 332 | print*,' details. change lith thickness or node density ' 333 | print*,' to avoid this ' 334 | print*,'####################################################' 335 | else if(icase.eq.4) then 336 | print*,'####################################################' 337 | print*,'####################################################' 338 | print*,'CASE 4: this is not implemented. see notes for ' 339 | print*,' details. change lith thickness or node density ' 340 | print*,' to avoid this ' 341 | print*,'####################################################' 342 | endif 343 | c############################################# 344 | c always end meshing from the end of the top 345 | c of the pro-lith to the model edge 346 | c############################################# 347 | nshiftlr=0; nshiftap=0; nshiftlp=0; nshiftar=0; 348 | itog_ap=0; itog_lp=0; itog_lr=0; itog_ar=0; 349 | iapon=0; ilpon=0; iaron=1; ilron=1; 350 | call mk_array(0,0,iapon,0,0,ilpon,1,nerowm,1,nrowar, 351 | *iaron,1,nrowlr,ilron,npltop,ncol,nshiftap,nshiftlp,nshiftar, 352 | *nshiftlr, 353 | *index,indexap,indexlp,indexm,indexar,indexlr,itog_ap,itog_lp, 354 | *itog_ar,itog_lr,idomain,imtnode,iplbnode,ipltnode,irlbnode, 355 | *imbnode); 356 | 357 | index=0 358 | do j=1,ncol-1 359 | do i=1,ntrow-1 360 | index=index+1 361 | ndomain(index)=domain(i+(j-1)*(ntrow-1)) 362 | index=index+1 363 | ndomain(index)=domain(i+(j)*(ntrow-1)) 364 | end do 365 | end do 366 | 367 | c set final node in array of lith base boundary 368 | plitht_nodes(npltop)=plitht_nodes(npltop-1)+ntrow-1 369 | plithb_nodes(nplbase)=plithb_nodes(nplbase-1)+ntrow-1 370 | end 371 | 372 | 373 | c######################################################## 374 | c combine nodes from differnt domains into one array 375 | c######################################################## 376 | subroutine mk_array(iapstart,iapstop,iapon,ilpstart, 377 | *ilpstop,ilpon,imstart,imstop,iarstart,iarstop, 378 | *iaron,ilrstart,ilrstop,ilron,icolstart,icolstop, 379 | *nshiftap,nshiftlp,nshiftar,nshiftlr,index,indexap,indexlp, 380 | *indexm,indexar,indexlr,itog_ap,itog_lp,itog_ar,itog_lr,idomain, 381 | *imtnode,iplbnode,ipltnode,irlbnode,imbnode) 382 | use dyn_arrays 383 | implicit real*8 (a-h,o-z) 384 | implicit integer (i-n) 385 | 386 | c loop over colms 387 | do icol=icolstart,icolstop 388 | if(itog_ap.eq.1) then 389 | nshiftap=nshiftap+1; 390 | endif 391 | if(itog_lp.eq.1) then 392 | nshiftlp=nshiftlp+1; 393 | endif 394 | if(itog_ar.eq.1) then 395 | nshiftar=nshiftar+1; 396 | endif 397 | if(itog_lr.eq.1) then 398 | nshiftlr=nshiftlr+1; 399 | endif 400 | c pro-asthenosphere 401 | if(iapon.eq.1) then 402 | do irow=iapstart,iapstop-nshiftap 403 | index=index+1; 404 | indexap=indexap+1; 405 | pos(index,1)=panode(indexap,1); 406 | pos(index,2)=panode(indexap,2); 407 | idomain=idomain+1 408 | domain(idomain)=4 409 | end do 410 | indexap=indexap+1; 411 | iplbnode=iplbnode+1 412 | plithb_nodes(iplbnode)=index+1 413 | endif 414 | c pro-lithosphere 415 | if(ilpon.eq.1) then 416 | do irow=ilpstart,ilpstop-nshiftlp 417 | index=index+1; 418 | indexlp=indexlp+1; 419 | pos(index,1)=plnode(indexlp,1); 420 | pos(index,2)=plnode(indexlp,2); 421 | idomain=idomain+1 422 | domain(idomain)=2 423 | end do 424 | indexlp=indexlp+1; 425 | ipltnode=ipltnode+1 426 | plitht_nodes(ipltnode)=index+1 427 | endif 428 | c retro-asthenosphere 429 | if(iaron.eq.1) then 430 | do irow=iarstart,iarstop+nshiftar 431 | index=index+1; 432 | indexar=indexar+1; 433 | pos(index,1)=ranode(indexar,1); 434 | pos(index,2)=ranode(indexar,2); 435 | idomain=idomain+1 436 | domain(idomain)=5 437 | end do 438 | indexar=indexar+1; 439 | endif 440 | c retro-lith 441 | if(ilron.eq.1) then 442 | irlbnode=irlbnode+1 443 | rlithb_nodes(irlbnode)=index+1 444 | do irow=ilrstart,ilrstop+nshiftlr 445 | index=index+1; 446 | indexlr=indexlr+1; 447 | pos(index,1)=rlnode(indexlr,1); 448 | pos(index,2)=rlnode(indexlr,2); 449 | idomain=idomain+1 450 | domain(idomain)=3 451 | end do 452 | indexlr=indexlr+1; 453 | endif 454 | c mech 455 | imbnode=imbnode+1 456 | mechb_nodes(imbnode)=index+1 457 | do irow=imstart,imstop 458 | index=index+1; 459 | indexm=indexm+1; 460 | pos(index,1)=cmnode(indexm,1); 461 | pos(index,2)=cmnode(indexm,2); 462 | idomain=idomain+1 463 | domain(idomain)=1 464 | end do 465 | idomain=idomain-1 466 | imtnode=imtnode+1 467 | mecht_nodes(imtnode)=index 468 | end do 469 | end 470 | 471 | c######################################################## 472 | c make nodes in pro-asthenosphere 473 | c######################################################## 474 | subroutine mk_panodes(nplbase,nsing,nparow,base) 475 | use dyn_arrays 476 | implicit real*8 (a-h,o-z) 477 | implicit integer (i-n) 478 | c det number of nodes in the domain 479 | nparow=nplbase-nsing+1 480 | index=0 481 | npa=nsing*nparow 482 | do i=1,nparow-1 483 | npa=npa+i 484 | end do 485 | allocate(panode(npa,2)) 486 | do i=1,nsing 487 | dy=(yplbase(i)-base)/dble(nparow-1) 488 | do j=1,nparow 489 | index=index+1 490 | panode(index,1)=xmbase(i) 491 | panode(index,2)=base+dble(j-1)*dy 492 | end do 493 | end do 494 | icount=0 495 | do i=nsing+1,nplbase-1 496 | icount=icount+1 497 | dy=(yplbase(i)-base)/dble(nparow-icount-1) 498 | do j=1,nparow-icount 499 | index=index+1 500 | panode(index,1)=xmbase(i) 501 | panode(index,2)=base+dble(j-1)*dy 502 | end do 503 | end do 504 | index=index+1 505 | panode(index,1)=xmbase(nplbase) 506 | panode(index,2)=yplbase(nplbase) 507 | c do i=1,npa 508 | c print*,panode(i,1),panode(i,2) 509 | c end do 510 | end 511 | 512 | c######################################################## 513 | c make nodes in retro asthenosphere 514 | c######################################################## 515 | subroutine mk_ranodes(nrlrow,nsing,npltop,nrarow,ncol, 516 | *base,irlbeg,irabeg) 517 | use dyn_arrays 518 | implicit real*8 (a-h,o-z) 519 | implicit integer (i-n) 520 | c det number of rows and number of nodes in region 521 | irabeg=nrlrow+nsing-1 522 | nrarow=npltop-irlbeg+1 523 | nra=(ncol-npltop+1)*nrarow 524 | do i=nrarow-1,1,-1 525 | nra=nra+i 526 | end do 527 | allocate(ranode(nra,2)) 528 | ranode(1,1)=xmbase(irabeg) 529 | ranode(1,2)=ypltop(irabeg) 530 | ranode(2,1)=xmbase(irabeg+1) 531 | ranode(2,2)=ypltop(irabeg+1) 532 | ranode(3,1)=xmbase(irabeg+1) 533 | ranode(3,2)=yrlbase(2) 534 | index=3 535 | do i=2,npltop-irabeg 536 | icount=i+1 537 | dy=(yrlbase(i+1)-ypltop(irabeg+i))/dble(icount-1) 538 | do j=1,icount 539 | index=index+1 540 | ranode(index,1)=0.0 541 | ranode(index,1)=xmbase(i+irabeg) 542 | ranode(index,2)=ypltop(i+irabeg)+dy*dble(j-1) 543 | end do 544 | end do 545 | do i=2,ncol-npltop+1 546 | dy=(yrlbase(npltop-irabeg+i)-base)/dble(nrarow-1) 547 | do j=1,nrarow 548 | index=index+1 549 | ranode(index,1)=xrlbase(i+npltop-irabeg) 550 | ranode(index,2)=base+dy*dble(j-1) 551 | end do 552 | end do 553 | c do i=1,nra 554 | c print*,ranode(i,1),ranode(i,2) 555 | c end do 556 | end 557 | 558 | c######################################################## 559 | c make node in the retro lithosphere 560 | c######################################################## 561 | subroutine mk_rlnodes(nsing,nrlrow,irlbeg,ncol) 562 | use dyn_arrays 563 | implicit real*8 (a-h,o-z) 564 | implicit integer (i-n) 565 | c det number of rows and number of nodes in region 566 | nrlrow=irlbeg-nsing+1 567 | nrl=(ncol-irlbeg+1)*nrlrow 568 | do i=nrlrow-1,1,-1 569 | nrl=nrl+i 570 | end do 571 | allocate(rlnode(nrl,2)) 572 | rlnode(1,1)=xmbase(nsing) 573 | rlnode(1,2)=ypltop(nsing) 574 | rlnode(2,1)=xmbase(nsing+1) 575 | rlnode(2,2)=ypltop(nsing+1) 576 | rlnode(3,1)=xmbase(nsing+1) 577 | rlnode(3,2)=ymbase(nsing+1) 578 | index=3 579 | do i=2,irlbeg-nsing 580 | icount=i+1 581 | dy=(ymbase(nsing+i)-ypltop(nsing+i))/dble(icount-1) 582 | do j=1,icount 583 | index=index+1 584 | rlnode(index,1)=xmbase(i+nsing) 585 | rlnode(index,2)=ypltop(i+nsing)+dble(j-1)*dy 586 | end do 587 | end do 588 | do i=1,ncol-irlbeg 589 | dy=(ymbase(irlbeg+i)-yrlbase(i+1))/dble(nrlrow-1) 590 | do j=1,nrlrow 591 | index=index+1 592 | rlnode(index,1)=xmbase(i+irlbeg) 593 | rlnode(index,2)=yrlbase(i+1)+dy*dble(j-1) 594 | end do 595 | end do 596 | c do i=1,nrl 597 | c print*,rlnode(i,1),rlnode(i,2) 598 | c end do 599 | end 600 | 601 | c######################################################## 602 | c make nodes in pro-lithosphere 603 | c######################################################## 604 | subroutine mk_plnodes(npltop,nplbase,nplrow,base) 605 | use dyn_arrays 606 | implicit real*8 (a-h,o-z) 607 | implicit integer (i-n) 608 | base=ypltop(npltop) 609 | c det # no rows in pro-lithosphere 610 | do i=1,npltop 611 | if(xpl(i).ge.xpl(nplbase)) then 612 | istart=i 613 | exit 614 | endif 615 | end do 616 | nplrow=npltop-istart+1 617 | c det size of node array 618 | npl=nplrow*nplbase 619 | do i=nplrow-1,1,-1 620 | npl=npl+i 621 | end do 622 | allocate(plnode(npl,2)) 623 | c det node locations 624 | index=0 625 | do i=1,nplbase 626 | dy=(ypltop(i)-yplbase(i))/dble(nplrow-1) 627 | do j=1,nplrow 628 | index=index+1 629 | plnode(index,1)=xmbase(i) 630 | plnode(index,2)=yplbase(i)+dble(j-1)*dy 631 | end do 632 | end do 633 | icount=0 634 | do i=nplbase+1,npltop-1 635 | icount=icount+1 636 | dy=(ypltop(i)-base)/dble(nplrow-1-icount) 637 | do j=1,nplrow-icount 638 | index=index+1 639 | plnode(index,1)=xmbase(i) 640 | plnode(index,2)=base+dble(j-1)*dy 641 | end do 642 | end do 643 | index=index+1 644 | plnode(index,1)=xmbase(npltop) 645 | plnode(index,2)=base 646 | c do i=1,npl 647 | c print*,plnode(i,1),plnode(i,2) 648 | c end do 649 | 650 | end 651 | 652 | c######################################################## 653 | c make nodes in the mech model 654 | c######################################################## 655 | subroutine mk_cmnodes(ncol,nerowm,iblay,iblayt,iflgblt,iflgbl, 656 | *tblayt,tblay) 657 | use dyn_arrays 658 | implicit real*8 (a-h,o-z) 659 | implicit integer (i-n) 660 | 661 | allocate(cmnode(ncol*nerowm,2)) 662 | index=0 663 | 664 | c check that defined thicknesses of boundary layers do not exceed 665 | c the pro side crustal thickness 666 | if(tblayt+tblay.ge.ymtop(1)-ymbase(1)) then 667 | print*,'######################################' 668 | print*,'## ERROR: prescribed thickness of ##' 669 | print*,'## boundary layers is greater than ##' 670 | print*,'## the crustal thickness. ##' 671 | print*,'## tblay+tblayt=',tblay+tblayt 672 | print*,'## crustal thickness=',ymtop(1)-ymbase(1) 673 | print*,'######################################' 674 | endif 675 | 676 | c define thickness for boundary layers so that their thickness remains 677 | c constant 678 | c user defined thickness of bounadry layers 679 | c top layer 680 | if(iflgblt.eq.1) then 681 | dyblayt=tblayt/dble(iblayt) 682 | endif 683 | c bottom layer 684 | if(iflgbl.eq.1) then 685 | dyblay=tblay/dble(iblay) 686 | endif 687 | c mixed: user defined and automatic even spacing 688 | c top layer 689 | if(iflgbl.eq.1.and.iflgblt.eq.0) then 690 | dyblayt=(ymtop(1)-ymbase(1)-tblay)/dble(nerowm-1-iblay) 691 | tblayt=dble(iblayt)*dyblayt 692 | endif 693 | c bottom layer 694 | if(iflgblt.eq.1.and.iflgbl.eq.0) then 695 | dyblay=(ymtop(1)-ymbase(1)-tblayt)/dble(nerowm-1-iblayt) 696 | tblay=dble(iblay)*dyblay 697 | endif 698 | c automatic even spacing of both layers 699 | if(iflgbl.eq.0.and.iflgblt.eq.0) then 700 | dyblay=(ymtop(1)-ymbase(1))/dble(nerowm-1) 701 | dyblayt=dyblay 702 | tblayt=dble(iblayt)*dyblayt 703 | tblay=dble(iblay)*dyblay 704 | endif 705 | 706 | c make sure that no boundary layers -> boundary layer thickness = 0 707 | if(iblayt.eq.0) then 708 | tblayt=0.0 709 | endif 710 | if(iblay.eq.0) then 711 | tblay=0.0 712 | endif 713 | 714 | c loop over all colms 715 | do i=1,ncol 716 | dy=(ymtop(i)-ymbase(i)-tblayt-tblay) 717 | * /dble(nerowm-1-iblay-iblayt) 718 | c const thickness for lower boundary layers 719 | do j=1,iblay 720 | index=index+1 721 | cmnode(index,1)=xmbase(i) 722 | cmnode(index,2)=ymbase(i)+dble(j-1)*dyblay 723 | end do 724 | c fanning thickness for all other layers 725 | do j=1,nerowm-iblayt-iblay 726 | index=index+1 727 | cmnode(index,1)=xmbase(i) 728 | cmnode(index,2)=ymbase(i)+tblay+dble(j-1)*dy 729 | end do 730 | c constant thickness for top boundary layers 731 | base=cmnode(index,2) 732 | do j=1,iblayt 733 | index=index+1 734 | cmnode(index,1)=xmbase(i) 735 | cmnode(index,2)=base+dble(j)*dyblayt 736 | end do 737 | end do 738 | end 739 | 740 | c######################################################### 741 | c make the boundaris of the lithosphere/mesh/asthenosphere 742 | c on the pro side and lithosphere/asthenosphere on the 743 | c retro side 744 | c######################################################### 745 | subroutine lith_bndry(nsing1,nsing,plthick,athick,ncol,npltop, 746 | *plvel,nplbase,rlthick,irlbeg,nrlbase) 747 | use dyn_arrays 748 | implicit real*8 (a-h,o-z) 749 | implicit integer (i-n) 750 | real(kind=8),allocatable::ylbtemp(:) 751 | c determine slope at the end of the loaded sub. lithosphere 752 | c used in continuing sub plate down to model boundary 753 | slp=(yltemp(nsing1)-yltemp(nsing1-1))/(xltemp(nsing1) 754 | *-xltemp(nsing1-1)) 755 | print*,' Angle at end of plate (deg): ',atan(slp)*180.0/3.1416 756 | 757 | c det number of nodes in top of sub lithos 758 | base=ymbase(1)-plthick-athick 759 | c if sub entension ends above model base 760 | if(yltemp(nsing1).ge.base) then 761 | icount=0 762 | do i=nsing+nsing1-1,ncol 763 | icount=icount+1 764 | dx=abs(xmbase(nsing+nsing1-1)-xmbase(i)) 765 | ytest=yltemp(nsing1)+dx*slp 766 | if(ytest.lt.base) then 767 | dif1=abs(ytest-base) 768 | dif2=abs(yltemp(nsing1)+(abs(xmbase(nsing+nsing1-1) 769 | * -xmbase(i-1)))*slp-base) 770 | if(dif1.ge.dif2) then 771 | npltop=nsing1+icount-1 772 | exit 773 | else 774 | npltop=nsing1+icount-2 775 | exit 776 | endif 777 | end if 778 | end do 779 | c make array for sub lithos top 780 | allocate(ypltop(nsing+npltop-1)) 781 | allocate(xpl(nsing+npltop-1)) 782 | do i=1,nsing1 783 | ypltop(i-1+nsing)=yltemp(i) 784 | xpl(i-1+nsing)=xltemp(i) 785 | end do 786 | index=0 787 | do i=nsing1+1,npltop-1 788 | xpl(i-1+nsing)=xmbase(nsing+i-1) 789 | dx=abs(xpl(i-1+nsing)-xmbase(nsing-1+nsing1)) 790 | ypltop(i-1+nsing)=yltemp(nsing1)+slp*dx 791 | end do 792 | ypltop(npltop+nsing-1)=base 793 | xpl(npltop+nsing-1)=xmbase(npltop+nsing-1) 794 | do i=1,nsing-1 795 | xpl(i)=xmbase(i) 796 | ypltop(i)=ymbase(i) 797 | end do 798 | npltop=npltop+nsing-1 799 | c if sub extension ends below model base 800 | else if (yltemp(nsing1).lt.base) then 801 | icount=0 802 | do i=1,nsing1 803 | if(yltemp(i).lt.base) then 804 | dif1=abs(base-yltemp(i-1)) 805 | dif2=abs(base-yltemp(i)) 806 | if(dif1.lt.dif2) then 807 | npltop=i-1 808 | else 809 | npltop=i 810 | endif 811 | exit 812 | endif 813 | end do 814 | c make arrays for sub lithos top 815 | allocate(ypltop(nsing+npltop-1)) 816 | allocate(xpl(nsing+npltop-1)) 817 | do i=1,nsing-1 818 | xpl(i)=xmbase(i) 819 | ypltop(i)=ymbase(i) 820 | end do 821 | do i=1,npltop-2 822 | xpl(i-1+nsing)=xltemp(i) 823 | ypltop(i-1+nsing)=yltemp(i) 824 | end do 825 | xpl(nsing+npltop-1)=xmbase(nsing+npltop-1) 826 | ypltop(nsing+npltop-1)=base 827 | npltop=npltop+nsing-1 828 | endif 829 | 830 | c make array for lithos/asthenos boundary on pro side 831 | c allocate temp storage for the array that is as long as the array 832 | c for the top. when final length is determined, store in perm. 833 | c array 834 | allocate(ylbtemp(npltop)) 835 | c ref flux value for conserving mass in sub. plate 836 | qx=plvel*plthick 837 | c thickness at lhs 838 | dx=xpl(2)-xpl(1) 839 | dy=ypltop(2)-ypltop(1) 840 | hyplen=(dx**2+dy**2)**0.5 841 | ylbtemp(1)=-qx/plvel*hyplen/dx+ypltop(1) 842 | do i=2,npltop-1 843 | dx=xpl(i+1)-xpl(i-1) 844 | dy=ypltop(i+1)-ypltop(i-1) 845 | hyplen=(dx**2+dy**2)**0.5 846 | test=-qx/plvel*hyplen/dx+ypltop(i) 847 | if(test.lt.base) then 848 | dif1=abs(test-base) 849 | dif2=abs(ylbtemp(i-1)-base) 850 | if(dif1.lt.dif2) then 851 | ylbtemp(i)=base 852 | nplbase=i 853 | else 854 | ylbtemp(i-1)=base 855 | nplbase=i-1 856 | endif 857 | exit 858 | endif 859 | ylbtemp(i)=test 860 | end do 861 | 862 | allocate(yplbase(nplbase)) 863 | do i=1,nplbase 864 | yplbase(i)=ylbtemp(i) 865 | end do 866 | deallocate(ylbtemp) 867 | 868 | c make array for lithos/asthenos boundary on retro side 869 | c determine hit point of boundary of sub lithos slab 870 | difmin=10.0e5 871 | imin=0 872 | do i=nsing+1,npltop 873 | dif=abs(ymbase(i)-rlthick-ypltop(i)) 874 | if(dif.lt.difmin) then 875 | difmin=dif 876 | imin=i 877 | endif 878 | end do 879 | c x node where base of retro lith touches sub lith 880 | irlbeg=imin 881 | nrlbase=ncol-irlbeg+1 882 | index=1 883 | allocate(yrlbase(nrlbase)) 884 | allocate(xrlbase(nrlbase)) 885 | yrlbase(1)=ypltop(irlbeg) 886 | xrlbase(1)=xmbase(irlbeg) 887 | do i=irlbeg+1,ncol 888 | index=index+1 889 | yrlbase(index)=ymbase(i)-rlthick 890 | xrlbase(index)=xmbase(i) 891 | end do 892 | end 893 | 894 | c######################################################### 895 | C calclate the additional deflection of the coupled plates 896 | c from the overlying load of water 897 | c######################################################### 898 | subroutine deflectw(wdepth,xp1,xp2,slen1,slen2,wtoler,fnode1 899 | *,fnode2,plam1,plam2,fk,rhof,np1,np2,npad,g,nsing1,ctoler, 900 | *dyinit1,dyinit2,yp2,yp1,wheight) 901 | implicit real*8 (a-h,o-z) 902 | implicit integer (i-n) 903 | real*8 xp1(*),xp2(*),yp1(*),yp2(*),fnode1(*),fnode2(*),slen1(*), 904 | *slen2(*),dyinit1(*),dyinit2(*) 905 | real(kind=8),allocatable::dloc1(:),dloc2(:),yp1pre(:),yp2pre(:) 906 | 907 | ychange=100.0*wtoler 908 | icount=0 909 | allocate(dloc1(np1)) 910 | allocate(dloc2(np2)) 911 | allocate(yp1pre(np1)) 912 | allocate(yp2pre(np2)) 913 | do i=1,np1 914 | dloc1(i)=0.0 915 | yp1pre(i)=yp1(i) 916 | fnode1(i)=0.0 917 | end do 918 | do i=1,np2 919 | dloc2(i)=0.0 920 | yp2pre(i)=yp2(i) 921 | fnode2(i)=0.0 922 | end do 923 | do while(ychange.gt.wtoler) 924 | icount=icount+1 925 | c define water height 926 | wheight=-yp1(np1-npad)+dyinit1(np1-npad)+wdepth 927 | c calculate loading due to water 928 | if(icount.eq.1) then 929 | c first step 930 | c plate 1 931 | c local water depth and resulting force 932 | do i=nsing1,np1 933 | dloc1(i)=wheight-(-yp1(i)+dyinit1(i)) 934 | if(dloc1(i).gt.0.0) then 935 | fnode1(i)=slen1(i)*g*rhof*dloc1(i) 936 | else 937 | fnode1(i)=0.0 938 | dloc1(i)=0.0 939 | endif 940 | end do 941 | c plate 2 942 | c local water depth and resulting force 943 | do i=1,np2 944 | dloc2(i)=wheight-(-yp2(i)+dyinit2(i)) 945 | if(dloc2(i).gt.0.0) then 946 | fnode2(i)=slen2(i)*g*rhof*dloc2(i) 947 | else 948 | fnode2(i)=0.0 949 | dloc2(i)=0.0 950 | endif 951 | end do 952 | else 953 | c all other steps 954 | c plate 1 955 | do i=nsing1,np1 956 | dtemp=wheight-(-yp1(i)+dyinit1(i)) 957 | c change in water depth 958 | deltad=dtemp-dloc1(i) 959 | if(dtemp.le.0.0) then 960 | dtemp=0.0 961 | if(dloc1(i).le.0.0) then 962 | fnode1(i)=0.0 963 | else 964 | fnode1(i)=slen1(i)*g*rhof*(-dloc1(i)) 965 | endif 966 | else 967 | fnode1(i)=slen1(i)*g*rhof*deltad 968 | endif 969 | dloc1(i)=dtemp 970 | end do 971 | c plate 2 972 | do i=1,np2 973 | dtemp=wheight-(-yp2(i)+dyinit2(i)) 974 | c change in water depth 975 | deltad=dtemp-dloc2(i) 976 | if(dtemp.le.0.0) then 977 | dtemp=0.0 978 | if(dloc2(i).le.0.0) then 979 | fnode2(i)=0.0 980 | else 981 | fnode2(i)=slen2(i)*g*rhof*(-dloc2(i)) 982 | endif 983 | else 984 | fnode2(i)=slen2(i)*g*rhof*deltad 985 | endif 986 | dloc2(i)=dtemp 987 | end do 988 | endif 989 | c############################ 990 | c calculate plate deflection 991 | c############################ 992 | c calculate deflection,moment,shear force at the desired break point for 993 | c two infinite plates 994 | c plate 1 995 | amom1=0.0 996 | ashear1=0.0 997 | call calc_dms(xp1,amom1,ashear1,np1,fnode1,plam1,yp1,fk) 998 | c plate 2 999 | amom2=0.0 1000 | ashear2=0.0 1001 | call calc_dms(xp2,amom2,ashear2,np2,fnode2,plam2,yp2,fk) 1002 | c calculate deflection of semi-infinite plates using 1003 | c the end cond forces and subduction load/moment 1004 | c plate 1 1005 | 1006 | adummy1=0.0 1007 | adummy2=0.0 1008 | 1009 | call deflect2(np1,plam1,fk,xp1,adummy1,adummy2,amom1,ashear1,yp1) 1010 | C call deflect2(np1,plam1,fk,xp1,0.0,0.0,amom1,ashear1,yp1) 1011 | c plate 2 1012 | call deflect2(np2,plam2,fk,xp2,adummy1,adummy2,amom2,ashear2,yp2) 1013 | C call deflect2(np2,plam2,fk,xp2,0.0,0.0,amom2,ashear2,yp2) 1014 | c calculate the coupling load 1015 | ido_again=1 1016 | jcount=0 1017 | do while(ido_again==1) 1018 | jcount=jcount+1 1019 | call couple(yp1,yp2,nsing,plam1,plam2,fk,xp1,xp2,np1,np2, 1020 | * nsing1) 1021 | if(abs(yp1(nsing1)-yp2(1)).le.ctoler) then 1022 | ido_again=0 1023 | print*,'diff. at s-point: ',abs(yp1(nsing1)-yp2(1)) 1024 | else if(jcount.gt.1000) then 1025 | ido_again=0 1026 | print*,'########################################' 1027 | print*,'## coupling iteration exceeded 1000 ##' 1028 | print*,'## inside water loop ##' 1029 | print*,'########################################' 1030 | call profdump(xbase,yp1,yp2,np1,np2,nsing,npad) 1031 | stop 1032 | endif 1033 | end do 1034 | dif=0.0 1035 | do j=1,np1 1036 | dif=dif+abs(yp1(j)-yp1pre(j)) 1037 | yp1pre(j)=yp1(j) 1038 | end do 1039 | do j=1,np2 1040 | dif=dif+abs(yp2(j)-yp2pre(j)) 1041 | yp2pre(j)=yp2(j) 1042 | end do 1043 | print*,'change in base due to water loading: ',dif 1044 | ychange=dif 1045 | if(icount.gt.1000) then 1046 | print*,'########################################' 1047 | print*,'## water depth iteration exceeded 1000##' 1048 | print*,'########################################' 1049 | call profdump(xbase,yp1,yp2,np1,np2,nsing,npad) 1050 | stop 1051 | endif 1052 | end do 1053 | deallocate(dloc1) 1054 | deallocate(dloc2) 1055 | deallocate(yp1pre) 1056 | deallocate(yp2pre) 1057 | end 1058 | 1059 | 1060 | c######################################################## 1061 | C calculate the deflection of two semi-infinite plates 1062 | c coupled together at the s-point from a distributed 1063 | c load as stored in fnode 1064 | c######################################################## 1065 | subroutine deflect(np1,np2,xp1,xp2,yp1,yp2,fnode1,fnode2 1066 | *,plam1,plam2,fk,ctoler,nsing1,sload,smomen,xbase,nsing,npad, 1067 | *dyc) 1068 | 1069 | implicit real*8 (a-h,o-z) 1070 | implicit integer (i-n) 1071 | real*8 xp1(*),xp2(*),yp1(*),yp2(*),fnode1(*),fnode2(*),xbase(*) 1072 | 1073 | c calculate deflection everywhere and moment,shear force at the 1074 | c desired break point for two infinite plates 1075 | c plate 1 1076 | amom1=0.0 1077 | ashear1=0.0 1078 | call calc_dms(xp1,amom1,ashear1,np1,fnode1,plam1,yp1,fk) 1079 | c plate 2 1080 | amom2=0.0 1081 | ashear2=0.0 1082 | call calc_dms(xp2,amom2,ashear2,np2,fnode2,plam2,yp2,fk) 1083 | 1084 | c calculate deflection of semi-infinite plates using 1085 | c the end cond forces and subduction load/moment 1086 | c plate 1 1087 | 1088 | adummy1=0.0 1089 | adummy2=0.0 1090 | 1091 | call deflect2(np1,plam1,fk,xp1,sload,smomen,amom1,ashear1,yp1) 1092 | c plate 2 1093 | call deflect2(np2,plam2,fk,xp2,adummy1,adummy2,amom2,ashear2,yp2) 1094 | C call deflect2(np2,plam2,fk,xp2,0.0,0.0,amom2,ashear2,yp2) 1095 | c call profdump(xbase,yp1,yp2,np1,np2,nsing,npad) 1096 | c stop 1097 | c calculate the coupling load and coupled position of plates 1098 | ido_again=1 1099 | icount=0 1100 | do while(ido_again==1) 1101 | icount=icount+1 1102 | call couple(yp1,yp2,nsing,plam1,plam2,fk,xp1,xp2,np1, 1103 | * np2,nsing1) 1104 | if(abs(yp1(nsing1)-yp2(1)).le.ctoler) then 1105 | ido_again=0 1106 | print*,'diff. at s-point: ',abs(yp1(nsing1)-yp2(1)) 1107 | else if(icount.gt.1000) then 1108 | ido_again=0 1109 | print*,'########################################' 1110 | print*,'## coupling iteration exceeded 1000 ##' 1111 | print*,'## in first calc ##' 1112 | print*,'########################################' 1113 | call profdump(xbase,yp1,yp2,np1,np2,nsing,npad) 1114 | stop 1115 | endif 1116 | end do 1117 | c allow for shifting of the coupling point 1118 | if(abs(dyc).gt.0.0) then 1119 | ido_again=1 1120 | icount=0 1121 | ycfinal=yp2(1)-dyc 1122 | do while(ido_again==1) 1123 | icount=icount+1 1124 | call shift_couple(yp1,yp2,nsing,plam1,plam2,fk,xp1,xp2,np1, 1125 | * np2,nsing1,ycfinal) 1126 | if(abs(yp1(nsing1)-yp2(1)).le.ctoler) then 1127 | ido_again=0 1128 | else if(icount.gt.1000) then 1129 | ido_again=0 1130 | print*,'########################################' 1131 | print*,'## coupling iteration exceeded 1000 ##' 1132 | print*,'## in couple point shift ##' 1133 | print*,'########################################' 1134 | call profdump(xbase,yp1,yp2,np1,np2,nsing,npad) 1135 | stop 1136 | endif 1137 | end do 1138 | endif 1139 | end 1140 | 1141 | C######################################################## 1142 | c calculate the new position of the plates after the 1143 | c coupling point has been shifted 1144 | C######################################################## 1145 | subroutine shift_couple(yp1,yp2,nsing,plam1,plam2,fk,xp1,xp2, 1146 | *np1,np2,nsing1,ycfinal) 1147 | implicit real*8 (a-h,o-z) 1148 | implicit integer (i-n) 1149 | real*8 yp1(*),yp2(*),xp1(*),xp2(*) 1150 | 1151 | c distances to shift both plates at the coupling point. 1152 | G0p1=yp1(nsing1)-ycfinal 1153 | G0p2=-yp2(1)+ycfinal 1154 | c calculations for plate 1 1155 | c deflection of infinite beam with the coupling load at s-point 1156 | G1=plam1/(2.0*fk)*exp(-plam1*xp1(nsing1))*(cos(plam1*xp1(nsing1)) 1157 | *+sin(plam1*xp1(nsing1))) 1158 | c moment at the plate end from coupling load 1159 | G2=1.0/(4.0*plam1)*exp(-plam1*xp1(nsing1))*(cos(plam1*xp1(nsing1)) 1160 | *-sin(plam1*xp1(nsing1))) 1161 | c shear force at the plate end from coupling load 1162 | G3=0.5*exp(-plam1*xp1(nsing1))*cos(plam1*xp1(nsing1)) 1163 | c end conditioning load 1164 | G4=4.0*plam1*G2+4.0*G3 1165 | c end conditioning moment 1166 | G5=-4.0*G2-2.0*G3/plam1 1167 | c deflection from end conditioning load 1168 | G6=G4*plam1/(2.0*fk)*exp(-plam1*xp1(nsing1))* 1169 | *(cos(plam1*xp1(nsing1))+sin(plam1*xp1(nsing1))) 1170 | c deflection from end conditioning moment 1171 | G7=G5*plam1**2/fk*exp(-plam1*xp1(nsing1))*sin(plam1*xp1(nsing1)) 1172 | fcouplep1=G0p1/(G1+G6+G7) 1173 | fcouplep2=G0p2*fk/(2.0*plam2) 1174 | c calculate deflection from coupling load and shift in couple point 1175 | do i=1,np1 1176 | yp1(i)=yp1(i) 1177 | * -(2.0*fcouplep1*plam1/fk*exp(-plam1*xp1(i))*cos(plam1*xp1(i))) 1178 | end do 1179 | do i=1,np2 1180 | yp2(i)=yp2(i) 1181 | * +(2.0*fcouplep2*plam2/fk*exp(-plam2*xp2(i))*cos(plam2*xp2(i))) 1182 | end do 1183 | end 1184 | 1185 | C######################################################## 1186 | c calculate the plate coupling load and couple the plates 1187 | c---Couples the plates so that both plates experience 1188 | c equal and opposite forces to couple them 1189 | c######################################################## 1190 | subroutine couple(yp1,yp2,nsing,plam1,plam2,fk,xp1,xp2, 1191 | *np1,np2,nsing1) 1192 | implicit real*8 (a-h,o-z) 1193 | implicit integer (i-n) 1194 | real*8 yp1(*),yp2(*),xp1(*),xp2(*) 1195 | 1196 | c difference in deflection between the two plates at s-point 1197 | G0=yp1(nsing1)-yp2(1) 1198 | c calculations for plate 1 1199 | c deflection of infinite beam with the coupling load at s-point 1200 | 1201 | G1=plam1/(2.0*fk)*exp(-plam1*xp1(nsing1))*(cos(plam1*xp1(nsing1)) 1202 | *+sin(plam1*xp1(nsing1))) 1203 | c moment at the plate end from coupling load 1204 | G2=1.0/(4.0*plam1)*exp(-plam1*xp1(nsing1))*(cos(plam1*xp1(nsing1)) 1205 | *-sin(plam1*xp1(nsing1))) 1206 | c shear force at the plate end from coupling load 1207 | G3=0.5*exp(-plam1*xp1(nsing1))*cos(plam1*xp1(nsing1)) 1208 | c end conditioning load 1209 | G4=4.0*plam1*G2+4.0*G3 1210 | c end conditioning moment 1211 | G5=-4.0*G2-2.0*G3/plam1 1212 | c deflection from end conditioning load 1213 | G6=G4*plam1/(2.0*fk)*exp(-plam1*xp1(nsing1))* 1214 | *(cos(plam1*xp1(nsing1))+sin(plam1*xp1(nsing1))) 1215 | c deflection from end conditioning moment 1216 | G7=G5*plam1**2/fk*exp(-plam1*xp1(nsing1))*sin(plam1*xp1(nsing1)) 1217 | fcouple=G0/((2.0*plam2)/fk+G1+G6+G7) 1218 | c calculate deflection from coupling load 1219 | do i=1,np1 1220 | yp1(i)=yp1(i) 1221 | * -(2.0*fcouple*plam1/fk*exp(-plam1*xp1(i))*cos(plam1*xp1(i))) 1222 | end do 1223 | do i=1,np2 1224 | yp2(i)=yp2(i) 1225 | * +(2.0*fcouple*plam2/fk*exp(-plam2*xp2(i))*cos(plam2*xp2(i))) 1226 | end do 1227 | end 1228 | 1229 | c######################################################## 1230 | c output the flexural profiles when then code dumps 1231 | c######################################################## 1232 | subroutine profdump(xbase,yp1,yp2,np1,np2,nsing,npad) 1233 | implicit integer (i-n) 1234 | implicit real (a-h,o-z) 1235 | real(kind=8) xbase(*),yp1(*),yp2(*) 1236 | 1237 | open(21,file='profiles/pro_plate_dump') 1238 | open(22,file='profiles/retro_plate_dump') 1239 | do k=1,np1 1240 | ip=np1-k+1 1241 | write(21,198)xbase(k)/1000.0,-yp1(ip)/1000.0 1242 | end do 1243 | do k=1,np2 1244 | write(22,198)xbase(nsing-1+k+npad)/1000.0,-yp2(k)/1000.0 1245 | end do 1246 | 198 format(2e17.8) 1247 | close(21) 1248 | close(22) 1249 | end 1250 | 1251 | c######################################################## 1252 | c calculate deflection of semi-infinite plates using 1253 | c the end cond forces and subduction load/moment 1254 | c######################################################## 1255 | subroutine deflect2(np,plam,fk,xp,sload,smomen,amom,ashear,yp) 1256 | implicit real*8 (a-h,o-z) 1257 | implicit integer (i-n) 1258 | real*8 xp(*),yp(*) 1259 | c calculate end conditioning forces 1260 | fmo=-4.0*amom-2.0*ashear/plam 1261 | fpo=4.0*(plam*amom+ashear) 1262 | c calculate deflection 1263 | do i=1,np 1264 | ypo=fpo*plam/(2.0*fk)*exp(-plam*xp(i))*(cos(plam*xp(i)) 1265 | * +sin(plam*xp(i))) 1266 | ymo=(fmo*plam**2)/fk*exp(-plam*xp(i))*sin(plam*xp(i)) 1267 | ysload=2.0*sload*plam/fk*exp(-plam*xp(i))*cos(plam*xp(i)) 1268 | ysmom=-2.0*smomen*plam**2/fk*exp(-plam*xp(i))*(cos(plam*xp(i)) 1269 | * -sin(plam*xp(i))) 1270 | yp(i)=ypo+ymo+ysload+ysmom+yp(i) 1271 | end do 1272 | end 1273 | 1274 | 1275 | c######################################################## 1276 | c calculate the moment and shear in an infinite plate 1277 | c######################################################## 1278 | subroutine calc_dms(xp,amom,ashear,np,fnode,plam,yp,fk) 1279 | implicit real*8 (a-h,o-z) 1280 | implicit integer (i-n) 1281 | real*8 xp(*),fnode(*),yp(*) 1282 | 1283 | do i=1,np 1284 | do j=1,np 1285 | dist=abs(xp(i)-xp(j)) 1286 | yp(j)=yp(j)+fnode(i)*plam/(2.0*fk)*exp(-plam*dist)* 1287 | * (cos(plam*dist) 1288 | * +sin(plam*dist)) 1289 | end do 1290 | dist=xp(i) 1291 | amom=amom+fnode(i)/(4.0*plam)*exp(-plam*dist)*(cos(plam*dist) 1292 | * -sin(plam*dist)) 1293 | ashear=ashear+fnode(i)/2.0*exp(-plam*dist)*cos(plam*dist) 1294 | end do 1295 | end 1296 | 1297 | c######################################################## 1298 | c calculate the force from the thickness of the mech model 1299 | c for calculating the flexure 1300 | c######################################################## 1301 | subroutine calc_force_p2(slen,xp,nerowm,rhoc,np,fnode,dyinit, 1302 | *npad,iplate,rhoavt,nsing,g,ncol,inflag,dencol) 1303 | 1304 | implicit real*8 (a-h,o-z) 1305 | implicit integer (i-n) 1306 | real*8 slen(*),xp(*),rhoc(*),fnode(*),dyinit(*),dencol(*) 1307 | 1308 | ifstrow=(nerowm-1)*(nsing-1) 1309 | ilstrow=(ncol-2)*(nerowm-2) 1310 | 1311 | c first node 1312 | slen(1)=(xp(2)-xp(1))/2.0 1313 | c average density of overlying colm, need for variable density models 1314 | c !!!!!ONLY WORKS WHEN Y SPACING OF ELEMENTS IS CONSTANT!!!!!! 1315 | c ALSO: the thickness of the plate 1 extension past nsing must be zero 1316 | c prob. want to check this before implementing varying densities 1317 | rhosum=0.0 1318 | do i=1,nerowm-1 1319 | rhosum=rhosum+rhoc(i+ifstrow) 1320 | end do 1321 | rhoav=rhosum/dble(nerowm-1) 1322 | if(inflag.eq.1) rhoav=dencol(nsing) 1323 | fnode(1)=slen(1)*g*rhoav*dyinit(1) 1324 | c last node 1325 | slen(np)=(xp(np)-xp(np-1))/2.0 1326 | rhosum=0.0 1327 | if(npad.eq.0) then 1328 | do i=1,nerowm-1 1329 | rhosum=rhosum+rhoc(i+ilstrow) 1330 | end do 1331 | rhoav=rhosum/dble(nerowm-1) 1332 | else 1333 | rhoav=rhoavt 1334 | endif 1335 | if(inflag.eq.1) rhoav=dencol(ncol) 1336 | fnode(np)=slen(np)*g*rhoav*dyinit(np) 1337 | c all other nodes 1338 | do icol=2,np-1 1339 | slen(icol)=(xp(icol+1)-xp(icol-1))/2.0 1340 | rhosum=0.0 1341 | c add catch for padded edges of model where density is not defined 1342 | if(icol.ge.np-npad) then 1343 | rhoav=rhoavt 1344 | if(inflag.eq.1) rhoav=dencol(ncol) 1345 | else 1346 | icol2=icol+nsing-1 1347 | dxr=xp(icol+1)-xp(icol) 1348 | dxl=xp(icol)-xp(icol-1) 1349 | sl=dxl/(dxl+dxr) 1350 | sr=dxr/(dxl+dxr) 1351 | do j=1,nerowm-1 1352 | rhosum=rhosum+sl*rhoc(j+(icol2-2)*(nerowm-1)) 1353 | * +sr*rhoc(j+(icol2-1)*(nerowm-1)) 1354 | end do 1355 | rhoav=rhosum/dble((nerowm-1)*1) 1356 | if(inflag.eq.1) rhoav=dencol(icol2) 1357 | end if 1358 | fnode(icol)=slen(icol)*g*rhoav*dyinit(icol) 1359 | end do 1360 | end 1361 | 1362 | c######################################################## 1363 | c calculate the force from the thickness of the mech model 1364 | c for calculating the flexure 1365 | c######################################################## 1366 | subroutine calc_force_p1(slen,xp,nerowm,rhoc,np,fnode,dyinit, 1367 | *npad,iplate,rhoavt,nsing,g,nsing1,inflag,dencol) 1368 | 1369 | implicit real*8 (a-h,o-z) 1370 | implicit integer (i-n) 1371 | real*8 slen(*),xp(*),rhoc(*),fnode(*),dyinit(*),dencol(*) 1372 | 1373 | ifstrow=(nerowm-1)*(np-1) 1374 | ilstrow=0 1375 | 1376 | c average density of overlying colm, need for variable density models 1377 | c !!!!!ONLY WORKS WHEN Y SPACING OF ELEMENTS IS CONSTANT!!!!!! 1378 | c ALSO: the thickness of the plate 1 extension past nsing must be zero 1379 | c prob. want to check this before implementing varying densities 1380 | 1381 | 1382 | c first node 1383 | c if there is an extended plate (sub plate), set forces to zero 1384 | slen(1)=(xp(2)-xp(1))/2.0 1385 | fnode(1)=0.0 1386 | do i=2,nsing1-1 1387 | slen(i)=(xp(i+1)-xp(i-1))/2.0 1388 | fnode(i)=0.0 1389 | end do 1390 | c calculate force at spoint as if it was the first colm 1391 | slen(nsing1)=(xp(nsing1+1)-xp(nsing1))/2.0 1392 | rhosum=0.0 1393 | do i=1,nerowm-1 1394 | rhosum=rhosum+rhoc((nsing-2)*(nerowm-1)+i) 1395 | end do 1396 | rhoav=rhosum/dble(nerowm-1) 1397 | c catch for reading in colms of ave density 1398 | if(inflag.eq.1) rhoav=dencol(nsing) 1399 | fnode(nsing1)=slen(nsing1)*g*rhoav*dyinit(nsing1) 1400 | c last node 1401 | slen(np)=(xp(np)-xp(np-1))/2.0 1402 | rhosum=0.0 1403 | if(npad.eq.0) then 1404 | do i=1,nerowm-1 1405 | rhosum=rhosum+rhoc(i) 1406 | end do 1407 | rhoav=rhosum/dble(nerowm-1) 1408 | else 1409 | rhoav=rhoavt 1410 | endif 1411 | if(inflag.eq.1) rhoav=dencol(1) 1412 | fnode(np)=slen(np)*g*rhoav*dyinit(np) 1413 | 1414 | c all other nodes 1415 | index=0 1416 | do icol=nsing1+1,np-1 1417 | slen(icol)=(xp(icol+1)-xp(icol-1))/2.0 1418 | rhosum=0.0 1419 | c add catch for padded edges of model where density is not defined 1420 | if(icol.ge.np-npad) then 1421 | rhoav=rhoavt 1422 | if(inflag.eq.1) rhoav=dencol(1) 1423 | else 1424 | index=index+1 1425 | icol2=nsing-index 1426 | dxl=xp(icol+1)-xp(icol) 1427 | dxr=xp(icol)-xp(icol-1) 1428 | sl=dxl/(dxl+dxr) 1429 | sr=dxr/(dxl+dxr) 1430 | do j=1,nerowm-1 1431 | rhosum=rhosum+sl*rhoc((icol2-2)*(nerowm-1)+j) 1432 | * +sr*rhoc((icol2-1)*(nerowm-1)+j) 1433 | end do 1434 | rhoav=rhosum/dble((nerowm-1)*1) 1435 | if(inflag.eq.1) rhoav=dencol(icol2) 1436 | end if 1437 | fnode(icol)=slen(icol)*g*rhoav*dyinit(icol) 1438 | end do 1439 | 1440 | end 1441 | 1442 | 1443 | c########################################################################## 1444 | c read in input file 1445 | c########################################################################## 1446 | subroutine input(ncol,nerowm,nstype,sing, 1447 | *pmthick,plthick,athick,rlthick,ypmbase,yrmbase,wdepth,wtoler, 1448 | *npad,xpad,prigp,rrigp,prigi,rrigi,sload,smomen,xadd,ctoler, 1449 | *plvel,upvel,iunflag,iunbeg,xunbeg,vrig,beta,epsinv, 1450 | *rhof,rhom,numvebn,numpbn,numsid,numvtbn,ntst,intout,intoutl, 1451 | *delt,minint,maxint,npass,toler,erosl,erosr,peros,rpow,ntt2, 1452 | *deltt2,iso,ntmchg,plscale,rlscale,blscale,dfact,slpmax,tmax, 1453 | *numvetbn,ioutflag,inflag,dyc,linflag,sdip,ipflag,itrench, 1454 | *iplasflg,iblay,iblayt,isedl,isedr,iexflg,ibasflg,nbastary, 1455 | *nbastind,intmrkb,ipkfill,ibasfill,sedmax,iflgcl,agecl,iflgblt, 1456 | *iflgbl,tblayt,tblay,noutput) 1457 | use dyn_arrays 1458 | implicit real*8 (a-h,o-z) 1459 | implicit integer (i-n) 1460 | 1461 | open(2,file='meshin_oly',position='rewind') 1462 | 1463 | c style of output (1=all, 0= just flexural profiles 1464 | read(2,106)dummy 1465 | read(2,101)ioutflag 1466 | c allow input files for xpositions, thickness and densities of mech model 1467 | c (1=read input files, 0= just use meshin) 1468 | read(2,106)dummy 1469 | read(2,101)inflag 1470 | if(inflag.eq.1) open(9,file='../data/flex_data',position='rewind') 1471 | c number of colms in model and lagrangian mesh style 1472 | read(2,106)dummy 1473 | read(2,101)ncol 1474 | c number of rows in mech 1475 | read(2,106)dummy 1476 | read(2,106)dummy 1477 | read(2,101)nerowm 1478 | c lagrangian mesh parameters 1479 | c (extent past pro side, extent past retro side, extent past base, 1480 | c node density compred to eulerian mesh) 1481 | read(2,106)dummy 1482 | read(2,106)dummy 1483 | read(2,106)dummy 1484 | read(2,103)plscale,rlscale,blscale,dfact 1485 | c s-point location 1486 | read(2,106)dummy 1487 | read(2,104)nstype,sing 1488 | c model thicknesses on the pro and retro side 1489 | read(2,106)dummy 1490 | read(2,103)pmthick,plthick,athick 1491 | read(2,106)dummy 1492 | read(2,106)dummy 1493 | read(2,103)rlthick 1494 | c relative dif in initial mech. base height for pro and reto 1495 | read(2,106)dummy 1496 | read(2,106)dummy 1497 | read(2,106)dummy 1498 | read(2,103)ypmbase,yrmbase 1499 | c water depth and tolerance for change in water depth 1500 | read(2,106)dummy 1501 | read(2,106)dummy 1502 | read(2,103)wdepth,wtoler 1503 | c x padding for aprox. an infinite plate 1504 | read(2,106)dummy 1505 | read(2,106)dummy 1506 | read(2,106)dummy 1507 | read(2,106)dummy 1508 | read(2,106)dummy 1509 | read(2,104)npad,xpad 1510 | c horizontal spacing 1511 | read(2,106)dummy 1512 | read(2,106)dummy 1513 | read(2,101)ninc 1514 | read(2,106)dummy 1515 | allocate(xbase(ncol+npad*2)) 1516 | allocate(dyinit(ncol+npad*2)) 1517 | allocate(dencol(ncol)) 1518 | c make model array 1519 | index=0 1520 | do i=1,ninc 1521 | read(2,104)nnodes,xstrt,xstp 1522 | do j=1,nnodes 1523 | index=index+1 1524 | xbase(index+npad)=xstrt+(xstp-xstrt)/float(nnodes-1)*(j-1) 1525 | end do 1526 | end do 1527 | if(index.ne.ncol) then 1528 | print*,'###########################################' 1529 | print*,'ERROR:' 1530 | print*,'Number of colms != num of nodes in x array' 1531 | print*,'###########################################' 1532 | stop 1533 | endif 1534 | c add on padding beyond model edges 1535 | do i=1,npad 1536 | dx=abs(xbase(1+npad)-xpad)/dble(npad)*dble(i) 1537 | xbase(npad+1-i)=xbase(npad+1)-dx 1538 | xbase(npad+ncol+i)=xbase(ncol+npad)+dx 1539 | end do 1540 | c dimensions used when making model arrays from obs data 1541 | c ie, when the profiles will be read in 1542 | read(2,106)dummy 1543 | read(2,106)dummy 1544 | read(2,106)dummy 1545 | read(2,103)t1,t2 1546 | if(inflag.eq.1) then 1547 | if(t2-t1.ne.xbase(npad+ncol))then 1548 | print*,'##############################################' 1549 | print*,'ERROR: the width of model array',xbase(npad+ncol) 1550 | print*,' does not equal the width' 1551 | print*,' defined by coastline ref',t2-t1 1552 | print*,'##############################################' 1553 | endif 1554 | endif 1555 | 1556 | c deviation in mechanical thickness from ref thickness defined above 1557 | read(2,106)dummy 1558 | read(2,106)dummy 1559 | read(2,101)ninc 1560 | read(2,106)dummy 1561 | do i=1,ncol+npad*2 1562 | dyinit(i)=pmthick 1563 | end do 1564 | do j=1,ninc 1565 | read(2,104)ntyp,beg,slp 1566 | if(ntyp.eq.0) then 1567 | ibeg=int(beg) 1568 | else if(ntyp.eq.1) then 1569 | do i=1+npad,ncol+npad 1570 | if(xbase(i).gt.beg) then 1571 | if(abs(beg-xbase(i)).ge.abs(beg-xbase(i-1))) then 1572 | ibeg=i-1-npad 1573 | exit 1574 | else 1575 | ibeg=i-npad 1576 | exit 1577 | endif 1578 | else if(xbase(i).eq.beg) then 1579 | ibeg=i-npad 1580 | exit 1581 | endif 1582 | end do 1583 | else 1584 | print*,'###########################################' 1585 | print*,'ERROR: change in thickness must be defined ' 1586 | print*,' on either a node or x position with the' 1587 | print*,' flag set as 0 (node) or 1 (pos) ' 1588 | print*,'###########################################' 1589 | stop 1590 | endif 1591 | do i=ibeg+1+npad,ncol+npad*2 1592 | dyinit(i)=(xbase(i)-xbase(i-1))*slp+dyinit(i-1) 1593 | end do 1594 | end do 1595 | c if reading in x array and thickness from file, redo the above 1596 | if(inflag.eq.1.) then 1597 | read(9,101)ncol2,nsing2 1598 | if(ncol2.ne.ncol.or.nsing2.ne.int(sing)) then 1599 | print*,'###############################################' 1600 | print*,'ERROR:' 1601 | print*,'ncol or nsing from flex_data dont match meshin' 1602 | print*,'###############################################' 1603 | endif 1604 | c read in data 1605 | do icol=1,ncol 1606 | read(9,239)xbase(npad+icol),dyinit(npad+icol),dencol(icol) 1607 | xbase(icol+npad)=xbase(icol+npad)*1000.0 1608 | dyinit(icol+npad)=dyinit(icol+npad)*1000.0 1609 | end do 1610 | c shift x coords so they start at zero 1611 | xshift=xbase(npad+1) 1612 | do icol=1,ncol 1613 | xbase(npad+icol)=xbase(npad+icol)-xshift 1614 | end do 1615 | c set thickness in padded region to the thickness at the model edge 1616 | do i=1,npad 1617 | dyinit(i)=dyinit(npad+1) 1618 | dyinit(npad+ncol+i)=dyinit(npad+ncol) 1619 | end do 1620 | endif 1621 | 1622 | c type of isostatic comp. 1623 | read(2,106)dummy 1624 | read(2,101)iso 1625 | c initial geometry flag 1626 | read(2,106)dummy 1627 | read(2,101)ipflag 1628 | c slab dip for prescribed profile 1629 | read(2,106)dummy 1630 | read(2,106)dummy 1631 | read(2,103)sdip 1632 | c begining of circular arc on pro side 1633 | read(2,106)dummy 1634 | read(2,106)dummy 1635 | read(2,104)ntyp,beg 1636 | if(ntyp.eq.0) then 1637 | ibeg=int(beg) 1638 | else if(ntyp.eq.1) then 1639 | do i=1+npad,ncol+npad 1640 | if(xbase(i).gt.beg) then 1641 | if(abs(beg-xbase(i)).ge.abs(beg-xbase(i-1))) then 1642 | ibeg=i-1-npad 1643 | exit 1644 | else 1645 | ibeg=i-npad 1646 | exit 1647 | endif 1648 | else if(xbase(i).eq.beg) then 1649 | ibeg=i-npad 1650 | exit 1651 | endif 1652 | end do 1653 | endif 1654 | itrench=ibeg 1655 | c flexural rigidity for plate profile calc 1656 | read(2,106)dummy 1657 | read(2,103)prigp,rrigp 1658 | c flexural rigidity for isotatic calc 1659 | read(2,106)dummy 1660 | read(2,103)prigi,rrigi 1661 | c subduction load 1662 | read(2,106)dummy 1663 | read(2,103)sload 1664 | c subduction moment 1665 | read(2,106)dummy 1666 | read(2,103)smomen 1667 | c shift in coupling point 1668 | read(2,106)dummy 1669 | read(2,103)dyc 1670 | c length of extra pro-plate for sub load 1671 | do i=1,5 1672 | read(2,106)dummy 1673 | end do 1674 | read(2,103)xadd 1675 | c extension flag (=1 don't inlcude extension for plasti input) 1676 | do i=1,4 1677 | read(2,106)dummy 1678 | end do 1679 | read(2,101)iexflg 1680 | c tolerance for plate coupling position 1681 | read(2,106)dummy 1682 | read(2,105)ctoler 1683 | c convergence and undeplating velocity 1684 | read(2,106)dummy 1685 | read(2,103)plvel,upvel 1686 | c underplating flag and position 1687 | read(2,106)dummy 1688 | read(2,106)dummy 1689 | read(2,107)iunflag,iunbeg,xunbeg 1690 | c find node for begining of up 1691 | if(iunflag.eq.2) then 1692 | call find_node(iunbeg,1,xunbeg,ncol,npad,xuse) 1693 | print*,'beg underplating at (node, xposition)' 1694 | print*,iunbeg,xuse 1695 | else 1696 | print*,'beg underplating at (node, xposition)' 1697 | print*,iunbeg,xbase(iunbeg+npad) 1698 | endif 1699 | c variable cohesion, int angle frict, density, min viscosity, activation 1700 | c energy, pre-exponential for mech model 1701 | read(2,106)dummy 1702 | read(2,106)dummy 1703 | read(2,106)dummy 1704 | read(2,101)ninc 1705 | read(2,106)dummy 1706 | read(2,106)dummy 1707 | allocate(coh((nerowm-1)*(ncol-1))) 1708 | allocate(phi((nerowm-1)*(ncol-1))) 1709 | allocate(rhoc((nerowm-1)*(ncol-1))) 1710 | allocate(vmin((nerowm-1)*(ncol-1))) 1711 | allocate(q((nerowm-1)*(ncol-1))) 1712 | allocate(prex((nerowm-1)*(ncol-1))) 1713 | allocate(expn((nerowm-1)*(ncol-1))) 1714 | do i=1,ninc 1715 | read(2,108)ibcol,iecol,ibrow,ierow,coht,phit,denst,vmint, 1716 | * qt,prext,expnt 1717 | if(iecol.gt.ncol-1) then 1718 | print*,'### ERROR:' 1719 | print*,' ending colm in changing mech props' 1720 | print*,' is greater than ncol-1' 1721 | stop 1722 | endif 1723 | if(ierow.gt.nerowm-1) then 1724 | print*,'### ERROR:' 1725 | print*,' ending row in changing mech props' 1726 | print*,' is greater than nerowm-1' 1727 | print*,' ',ierow,nerowm-1 1728 | stop 1729 | endif 1730 | do icol=ibcol,iecol 1731 | do irow=ibrow,ierow 1732 | coh((icol-1)*(nerowm-1)+irow)=coht 1733 | phi((icol-1)*(nerowm-1)+irow)=phit 1734 | rhoc((icol-1)*(nerowm-1)+irow)=denst 1735 | vmin((icol-1)*(nerowm-1)+irow)=vmint 1736 | q((icol-1)*(nerowm-1)+irow)=qt 1737 | prex((icol-1)*(nerowm-1)+irow)=prext 1738 | expn((icol-1)*(nerowm-1)+irow)=expnt 1739 | end do 1740 | end do 1741 | end do 1742 | c number of boundary layers 1743 | do i=1,8 1744 | read(2,106)dummy 1745 | end do 1746 | read(2,111)iblayt,iflgblt,tblayt 1747 | read(2,106)dummy 1748 | read(2,111)iblay,iflgbl,tblay 1749 | c variable thermal properties for mech domain 1750 | do i=1,5 1751 | read(2,106)dummy 1752 | end do 1753 | read(2,101)ntmchg 1754 | allocate(tm_prop(ntmchg,9)) 1755 | read(2,106)dummy 1756 | do i=1,ntmchg 1757 | read(2,108)itemp1,itemp2,itemp3,itemp4,tm_prop(i,5), 1758 | * tm_prop(i,6),tm_prop(i,7),tm_prop(i,8),tm_prop(i,9) 1759 | if(itemp2.gt.ncol-1) then 1760 | print*,'### ERROR:' 1761 | print*,' ending colm in changing thermal props' 1762 | print*,' is greater than ncol-1' 1763 | stop 1764 | endif 1765 | if(itemp4.gt.nerowm-1) then 1766 | print*,'### ERROR:' 1767 | print*,' ending row in changing thermal props' 1768 | print*,' is greater than nerowm-1' 1769 | print*,' ',itemp4,nerowm-1 1770 | stop 1771 | endif 1772 | tm_prop(i,1)=dble(itemp1) 1773 | tm_prop(i,2)=dble(itemp2) 1774 | tm_prop(i,3)=dble(itemp3) 1775 | tm_prop(i,4)=dble(itemp4) 1776 | end do 1777 | c rigid viscosity 1778 | read(2,106)dummy 1779 | read(2,103)vrig 1780 | c compressibility 1781 | read(2,106)dummy 1782 | read(2,103)beta 1783 | print*,beta 1784 | c flag for linear or non-linear eqns 1785 | read(2,106)dummy 1786 | read(2,101)linflag 1787 | c flag for just plastic def 1788 | read(2,106)dummy 1789 | read(2,101)iplasflg 1790 | c epsinv 1791 | read(2,106)dummy 1792 | read(2,105)epsinv 1793 | c tmax 1794 | read(2,106)dummy 1795 | read(2,103)tmax 1796 | c densities of fluid and mantle 1797 | do i=1,4 1798 | read(2,106)dummy 1799 | end do 1800 | read(2,103)rhof,rhom 1801 | c # of boundary nodes: vel, pressure, loaded sides, tan vel 1802 | read(2,106)dummy 1803 | read(2,106)dummy 1804 | read(2,101)numvebn,numvetbn,numpbn,numsid,numvtbn 1805 | if(numvtbn.ne.ncol) then 1806 | print*,'###################### ERROR ##########################' 1807 | print*,'## need to have the number of tan vel bcs match ncol ##' 1808 | print*,'###################### ERROR ##########################' 1809 | stop 1810 | end if 1811 | c # tsteps, out int, out int lagrangian, tstep length 1812 | read(2,106)dummy 1813 | read(2,109)ntst,intout,intoutl,delt 1814 | c min inter, max iter, num filtering passes, convergence tolerance 1815 | read(2,106)dummy 1816 | read(2,109)minint,maxint,npass,toler 1817 | c erosion parameters 1818 | read(2,106)dummy 1819 | read(2,103)erosl,erosr,peros,rpow 1820 | c sedimentation paramters 1821 | read(2,106)dummy 1822 | read(2,106)dummy 1823 | read(2,106)dummy 1824 | read(2,112)ipkfill,ibasfill,isedl,isedr,sedmax 1825 | if(isedl.gt.ncol.or.isedr.gt.ncol) then 1826 | print*,'######################################################' 1827 | print*,'## ERROR: bounds of sedimenation need to be within ##' 1828 | print*,'## the model bounds. ncol=',ncol 1829 | print*,'######################################################' 1830 | stop 1831 | endif 1832 | if(ipkfill.eq.0.and.ibasfill.eq.1) then 1833 | print*,'######################################################' 1834 | print*,'## ERROR: cannot fill bounding basins w/o filling ##' 1835 | print*,'## between peaks ##' 1836 | print*,'######################################################' 1837 | stop 1838 | endif 1839 | c basin tracking parameters 1840 | read(2,106)dummy 1841 | read(2,106)dummy 1842 | read(2,106)dummy 1843 | read(2,101)ibasflg,nbastary,nbastind,intmrkb 1844 | c maximum slope 1845 | read(2,106)dummy 1846 | read(2,106)dummy 1847 | read(2,103)slpmax 1848 | c thermal runup 1849 | read(2,106)dummy 1850 | read(2,104)ntt2,deltt2 1851 | c variable thermal props 1852 | read(2,106)dummy 1853 | read(2,106)dummy 1854 | read(2,106)dummy 1855 | read(2,106)dummy 1856 | allocate(therm_prop(5,5)) 1857 | do i=1,5 1858 | read(2,103)therm_prop(i,1),therm_prop(i,2), 1859 | * therm_prop(i,3),therm_prop(i,4),therm_prop(i,5) 1860 | end do 1861 | c BCs for thermal problem 1862 | c ss bcs 1863 | do i=1,7 1864 | read(2,106)dummy 1865 | end do 1866 | allocate(thermbcs(1,2)) 1867 | read(2,103)thermbcs(1,1),thermbcs(1,2) 1868 | c cooling lithos bcs 1869 | do i=1,4 1870 | read(2,106)dummy 1871 | end do 1872 | read(2,104)iflgcl,agecl 1873 | c read in bcs for mech model 1874 | read(2,106)dummy 1875 | read(2,106)dummy 1876 | read(2,106)dummy 1877 | allocate(bc(5,numvebn+numvetbn+numpbn+numsid+numvtbn)) 1878 | index1=0 1879 | c x vel at model edges 1880 | read(2,101)nsets 1881 | idum=1 1882 | do 300 is=1,nsets 1883 | read(2,110)num,istart,inc,val 1884 | ifin=istart+(num-1)*inc 1885 | do 320 i=istart,ifin,inc 1886 | c write(3,111) i,idum,val 1887 | index1=index1+1 1888 | bc(1,index1)=float(i) 1889 | bc(2,index1)=float(idum) 1890 | bc(3,index1)=val 1891 | 320 continue 1892 | 300 continue 1893 | c y vel at model edges 1894 | read(2,101)nsets 1895 | idum=2 1896 | do 400 is=1,nsets 1897 | read(2,110)num,istart,inc,val 1898 | ifin=istart+(num-1)*inc 1899 | do 420 i=istart,ifin,inc 1900 | c write(3,111) i,idum,val 1901 | index1=index1+1 1902 | bc(1,index1)=float(i) 1903 | bc(2,index1)=float(idum) 1904 | bc(3,index1)=val 1905 | 420 continue 1906 | 400 continue 1907 | c pressure 1908 | read(2,101)nsets 1909 | do 500 is=1,nsets 1910 | read(2,110)num,istart,inc,val 1911 | ifin=istart+(num-1)*inc 1912 | do 520 i=istart,ifin,inc 1913 | c write(3,111) i,'0.0',val 1914 | index1=index1+1 1915 | bc(1,index1)=float(i) 1916 | bc(2,index1)=0.0 1917 | bc(3,index1)=val 1918 | 520 continue 1919 | 500 continue 1920 | c tangential velocities at model edges 1921 | c insetad of specifying x and y vel at the lhs and rhs model edges, 1922 | c specify a velocity tangential to the first two nodes at the base 1923 | c of the model 1924 | read(2,101)nsets 1925 | do 425 is=1,nsets 1926 | read(2,110)num,istart,inc,val 1927 | ifin=istart+(num-1)*inc 1928 | do 435 i=istart,ifin,inc 1929 | c write(3,111) i,val,'0.0' 1930 | index1=index1+1 1931 | bc(1,index1)=float(i) 1932 | bc(2,index1)=val 1933 | bc(3,index1)=0.0 1934 | 435 continue 1935 | 425 continue 1936 | c tangential velocity 1937 | read(2,101)nsets 1938 | do 800 is=1,nsets 1939 | read(2,110)num,istart,inc,val,val2 1940 | ifin=istart+(num-1)*inc 1941 | do 820 i=istart,ifin,inc 1942 | c write(3,111) i,val,'0.0' 1943 | index1=index1+1 1944 | bc(1,index1)=float(i) 1945 | bc(2,index1)=val 1946 | bc(3,index1)=0.0 1947 | 820 continue 1948 | 800 continue 1949 | c loaded sides 1950 | read(2,101)nsets 1951 | if(nsets.eq.0)go to 601 1952 | print*,'#######################################################' 1953 | print*,'## WARNING: mesh generator is not set up to process ##' 1954 | print*,'## loaded sides. also not in sub. output ##' 1955 | print*,'#######################################################' 1956 | stop 1957 | do 600 is=1,nsets 1958 | read(2,110)num,istart,inc,val 1959 | ifin=istart+(num-1)*inc 1960 | do 620 i=istart,ifin,inc 1961 | ii=i+nrowc 1962 | iii=ii+nrowc 1963 | iiii=1 1964 | c write(3,111) i,ii,iii,iiii,val 1965 | index1=inde1+1 1966 | 620 continue 1967 | 600 continue 1968 | 601 continue 1969 | c backstop nodes 1970 | read(2,101)nsets 1971 | if(nsets.eq.0)go to 701 1972 | print*,'#######################################################' 1973 | print*,'## WARNING: mesh generator is not set up to process ##' 1974 | print*,'## backstop nodes. (also not in sub. output)#' 1975 | print*,'#######################################################' 1976 | stop 1977 | do 700 is=1,nsets 1978 | read(2,110)num,istart,inc 1979 | ifin=istart+(num-1)*inc 1980 | do 720 i=istart,ifin,inc 1981 | c write(3,111) i 1982 | 720 continue 1983 | 700 continue 1984 | 701 continue 1985 | 1986 | c 1987 | c read in flags for output files 1988 | c 1989 | 1990 | c numer of possible files 1991 | do i=1,4 1992 | read(2,106)dummy 1993 | end do 1994 | read(2,101)noutput 1995 | allocate(output_flags(noutput)) 1996 | read(2,106)dummy 1997 | icount=1 1998 | c coord 1999 | read(2,113)dummy,iflag 2000 | output_flags(icount)=iflag 2001 | c vel 2002 | read(2,106)dummy 2003 | read(2,113)dummy,iflag 2004 | icount=icount+1 2005 | output_flags(icount)=iflag 2006 | c press 2007 | read(2,106)dummy 2008 | read(2,113)dummy,iflag 2009 | icount=icount+1 2010 | output_flags(icount)=iflag 2011 | c stresses and stuff 2012 | read(2,106)dummy 2013 | do i=1,7 2014 | read(2,113)dummy,iflag 2015 | icount=icount+1 2016 | output_flags(icount)=iflag 2017 | end do 2018 | c strain rates, dilitation 2019 | read(2,106)dummy 2020 | do i=1,6 2021 | read(2,113)dummy,iflag 2022 | icount=icount+1 2023 | output_flags(icount)=iflag 2024 | end do 2025 | c lmesh 2026 | read(2,106)dummy 2027 | read(2,113)dummy,iflag 2028 | icount=icount+1 2029 | output_flags(icount)=iflag 2030 | c temp_mech 2031 | read(2,106)dummy 2032 | read(2,113)dummy,iflag 2033 | icount=icount+1 2034 | output_flags(icount)=iflag 2035 | c visc_elem and visc_gp 2036 | read(2,106)dummy 2037 | read(2,113)dummy,iflag 2038 | icount=icount+1 2039 | output_flags(icount)=iflag 2040 | read(2,113)dummy,iflag 2041 | icount=icount+1 2042 | output_flags(icount)=iflag 2043 | c erosion 2044 | read(2,106)dummy 2045 | read(2,113)dummy,iflag 2046 | icount=icount+1 2047 | output_flags(icount)=iflag 2048 | c temp_track 2049 | read(2,106)dummy 2050 | read(2,113)dummy,iflag 2051 | icount=icount+1 2052 | output_flags(icount)=iflag 2053 | c unvel 2054 | read(2,106)dummy 2055 | read(2,113)dummy,iflag 2056 | icount=icount+1 2057 | output_flags(icount)=iflag 2058 | c exhum 2059 | read(2,106)dummy 2060 | read(2,113)dummy,iflag 2061 | icount=icount+1 2062 | output_flags(icount)=iflag 2063 | c surf_prof 2064 | read(2,106)dummy 2065 | read(2,113)dummy,iflag 2066 | icount=icount+1 2067 | output_flags(icount)=iflag 2068 | c duc_flag 2069 | read(2,106)dummy 2070 | read(2,113)dummy,iflag 2071 | icount=icount+1 2072 | output_flags(icount)=iflag 2073 | c material props 2074 | read(2,106)dummy 2075 | do i=1,7 2076 | read(2,113)dummy,iflag 2077 | icount=icount+1 2078 | output_flags(icount)=iflag 2079 | end do 2080 | c basinfill 2081 | read(2,106)dummy 2082 | read(2,113)dummy,iflag 2083 | icount=icount+1 2084 | output_flags(icount)=iflag 2085 | c peakchop 2086 | read(2,106)dummy 2087 | read(2,113)dummy,iflag 2088 | icount=icount+1 2089 | output_flags(icount)=iflag 2090 | c basin_track 2091 | read(2,106)dummy 2092 | read(2,113)dummy,iflag 2093 | icount=icount+1 2094 | output_flags(icount)=iflag 2095 | c l_temp_all 2096 | read(2,106)dummy 2097 | read(2,113)dummy,iflag 2098 | icount=icount+1 2099 | output_flags(icount)=iflag 2100 | c coordt 2101 | read(2,106)dummy 2102 | read(2,113)dummy,iflag 2103 | icount=icount+1 2104 | output_flags(icount)=iflag 2105 | c velthermal_alt 2106 | read(2,106)dummy 2107 | read(2,113)dummy,iflag 2108 | icount=icount+1 2109 | output_flags(icount)=iflag 2110 | c velthermal 2111 | read(2,106)dummy 2112 | read(2,113)dummy,iflag 2113 | icount=icount+1 2114 | output_flags(icount)=iflag 2115 | c temp.dat (entire model) 2116 | read(2,106)dummy 2117 | read(2,113)dummy,iflag 2118 | icount=icount+1 2119 | output_flags(icount)=iflag 2120 | c thermal props 2121 | read(2,106)dummy 2122 | do i=1,3 2123 | read(2,113)dummy,iflag 2124 | print*,dummy,iflag 2125 | icount=icount+1 2126 | output_flags(icount)=iflag 2127 | end do 2128 | c update size of output flag array 2129 | noutput=icount 2130 | 2131 | if(inflag.eq.1) close(9) 2132 | close(2) 2133 | 101 format(9i5) 2134 | 103 format(6e10.2) 2135 | 104 format(i5,2e10.2) 2136 | 105 format(f7.2,i5) 2137 | 106 format(a10) 2138 | 107 format(i2,i4,e10.2) 2139 | 108 format(4i4,9e10.2) 2140 | 109 format(3i5,e10.2) 2141 | 110 format(3i5,2d15.6) 2142 | 111 format(2i5,e10.2) 2143 | 112 format(4i5,e10.2) 2144 | 113 format(a15,i5) 2145 | 239 format(3e15.5) 2146 | 2147 | end 2148 | 2149 | c####################################### 2150 | c make x,y arrays for each plate 2151 | c####################################### 2152 | subroutine mk_plates(ncol,npad,xsing,xadd,np1,nsing,nsing1,np2) 2153 | use dyn_arrays 2154 | implicit real*8 (a-h,o-z) 2155 | implicit integer (i-n) 2156 | c PLATE 1 2157 | c calculate how many nodes to include for plate one to extend 2158 | c xadd past the spoint 2159 | if(xsing+xadd.gt.xbase(npad*2+ncol)) then 2160 | np1=ncol+npad*2 2161 | print*,'WARNING: Sub. extension goes past end of model' 2162 | else 2163 | do i=1,ncol+npad*2 2164 | if(xbase(i).gt.xsing+xadd) then 2165 | if(abs(xsing+xadd-xbase(i)). 2166 | * ge.abs(xadd+xsing-xbase(i-1))) then 2167 | np1=i-1 2168 | exit 2169 | else 2170 | np1=i 2171 | exit 2172 | endif 2173 | else if(xbase(i).eq.xadd+xsing) then 2174 | np1=i 2175 | exit 2176 | endif 2177 | end do 2178 | endif 2179 | print*,'length of plate 1 with sub exten (desired,used):' 2180 | print*,' ',xsing+xadd,xbase(np1) 2181 | c make x array for plate 1 2182 | allocate(xp1(np1)) 2183 | allocate(yp1(np1)) 2184 | allocate(dyinit1(np1)) 2185 | do i=1,np1 2186 | xp1(i)=xbase(np1)-xbase(np1-i+1) 2187 | yp1(i)=0.0 2188 | dyinit1(i)=0.0 2189 | end do 2190 | if(np1.gt.nsing+npad) then 2191 | nsing1=np1-(nsing+npad)+1 2192 | else 2193 | nsing1=1 2194 | endif 2195 | c make initial mech. model thickness array for plate 1 2196 | c ensure thickness past spoint is zero 2197 | do i=1,nsing+npad 2198 | dyinit1(np1-i+1)=dyinit(i) 2199 | end do 2200 | do i=1,np1 2201 | end do 2202 | c PLATE 2 2203 | c make x array 2204 | c note: plate 1 and 2 have the same begining node at s point 2205 | np2=ncol+2*npad-(nsing+npad)+1 2206 | allocate(yp2(np2)) 2207 | allocate(xp2(np2)) 2208 | allocate(dyinit2(np2)) 2209 | do i=1,np2 2210 | xp2(i)=xbase(i+nsing+npad-1)-xbase(nsing+npad) 2211 | yp2(i)=0.0 2212 | dyinit2(i)=0.0 2213 | end do 2214 | c make initial mech. model thickness array for plate 2 2215 | do i=1,np2 2216 | dyinit2(i)=dyinit(nsing-1+i+npad) 2217 | end do 2218 | end 2219 | 2220 | c######################################################### 2221 | c main loop to calculate flexure of the two plates 2222 | c######################################################### 2223 | subroutine calc_flex(nerowm,ncol,np1,np2,prigi,rrigi,rhom, 2224 | *npad,nsing,nsing1,ctoler,sload,smomen,wdepth,wtoler,rhof, 2225 | *ypmbase,yrmbase,wheight,inflag,dyc) 2226 | use dyn_arrays 2227 | implicit real*8 (a-h,o-z) 2228 | implicit integer (i-n) 2229 | c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 2230 | C NOTE: there is no rhof in the def of alpha. 2231 | c see project notes for description of method of calculating flexure and 2232 | c why the rhof is left out. In brief, it is left out because the forces 2233 | c acting on the imaginary plate are calculated as the load from the crust 2234 | c and the load from the water. Another way to do this problem would be 2235 | c to use rhof in the eqn and calculate just the loads from the crust. 2236 | c In this case the force from any portion of a colm of crust that is below a 2237 | c defined sea level is (rhoc-rhof)*g*h and the force form the portion of 2238 | c the same colm above sea level (if there is a sub aerial portion) is 2239 | c rhoc*g*h', where h' is the height of the colm above sea level 2240 | c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 2241 | 2242 | c calculate flexural parameters 2243 | g=9.8 2244 | alpha1=(4.0*prigi/((rhom)*g))**0.25 2245 | alpha2=(4.0*rrigi/((rhom)*g))**0.25 2246 | plam1=1.0/alpha1 2247 | plam2=1.0/alpha2 2248 | fk=rhom*g 2249 | 2250 | c######################################################## 2251 | c caculate force on each node from mech. model thickness 2252 | c######################################################## 2253 | allocate(slen1(np1)) 2254 | allocate(fnode1(np1)) 2255 | allocate(slen2(np2)) 2256 | allocate(fnode2(np2)) 2257 | 2258 | c calculate average density of the colms at the LHS and RHS of model domain 2259 | c for use in calculating the force on the padded sections of the profiles. 2260 | c this is not really an average density since it does not take into account 2261 | c differences in the size of elements, but it will work for this use 2262 | rhosum=0.0 2263 | do j=1,nerowm-1 2264 | rhosum=rhosum+rhoc(j) 2265 | end do 2266 | rhoavtl=rhosum/dble(nerowm-1) 2267 | rhosum=0.0 2268 | do j=1,nerowm-1 2269 | rhosum=rhosum+rhoc((nerowm-1)*(ncol-2)+j) 2270 | end do 2271 | rhoavtr=rhosum/dble(nerowm-1) 2272 | c plate 1 2273 | call calc_force_p1(slen1,xp1,nerowm,rhoc,np1,fnode1,dyinit1, 2274 | *npad,1,rhoavtl,nsing,g,nsing1,inflag,dencol) 2275 | c plate 2 2276 | call calc_force_p2(slen2,xp2,nerowm,rhoc,np2,fnode2,dyinit2, 2277 | *npad,2,rhoavtr,nsing,g,ncol,inflag,dencol) 2278 | c shift initial y positions for intial offsets defined above 2279 | do i=1,np1 2280 | yp1(i)=-ypmbase 2281 | end do 2282 | do i=1,np2 2283 | yp2(i)=-yrmbase 2284 | end do 2285 | c calculate defection of plates from distributed load due to thickness of 2286 | c mech model, subduction end load/moment, shift in coupling point, 2287 | c moment at coupling point and coupling constraint 2288 | call deflect(np1,np2,xp1,xp2,yp1,yp2,fnode1,fnode2,plam1,plam2, 2289 | *fk,ctoler,nsing1,sload,smomen,xbase,nsing,npad,dyc) 2290 | c calculate the deflection from the load of overlying water 2291 | if(wdepth.gt.0.0) then 2292 | call deflectw(wdepth,xp1,xp2,slen1,slen2,wtoler,fnode1, 2293 | * fnode2,plam1,plam2,fk,rhof,np1,np2,npad,g,nsing1,ctoler, 2294 | * dyinit1,dyinit2,yp2,yp1,wheight) 2295 | dif=0.0 2296 | endif 2297 | 2298 | c################################### 2299 | c check that plates do not overlap 2300 | c################################### 2301 | do i=1,nsing1-1 2302 | if(abs(yp1(i)).lt.abs(yp2(nsing1-i+1))) then 2303 | print*,'###############################' 2304 | print*,'## ERROR: plates overlap ##' 2305 | print*,'###############################' 2306 | call profdump(xbase,yp1,yp2,np1,np2,nsing,npad) 2307 | stop 2308 | endif 2309 | end do 2310 | deallocate(fnode1) 2311 | deallocate(fnode2) 2312 | deallocate(slen1) 2313 | deallocate(slen2) 2314 | end 2315 | 2316 | c############################################################### 2317 | c make arrays of flexure profile for model (mech and sub lithos) 2318 | c############################################################### 2319 | subroutine mech_bndry(ncol,nsing1,nsing,np1,npad,np2, 2320 | *plthick,athick,yshift) 2321 | use dyn_arrays 2322 | implicit real*8 (a-h,o-z) 2323 | implicit integer (i-n) 2324 | c make arrays mech model upper/lower boundary, sub. lithos 2325 | allocate(ymbase(ncol),ymtop(ncol)) 2326 | allocate(yltemp(nsing1)) 2327 | allocate(xltemp(nsing1)) 2328 | allocate(xmbase(ncol)) 2329 | c mech model boundary 2330 | do i=1,nsing 2331 | ymbase(i)=-yp1(np1-npad+1-i) 2332 | ymtop(i)=-yp1(np1-npad+1-i)+dyinit(i+npad) 2333 | xmbase(i)=xbase(i+npad) 2334 | end do 2335 | do i=1,np2-npad-1 2336 | ymbase(i+nsing)=-yp2(i+1) 2337 | ymtop(i+nsing)=-yp2(i+1)+dyinit(nsing+i+npad) 2338 | xmbase(i+nsing)=xbase(i+nsing+npad) 2339 | end do 2340 | c top of sub lithos past spoint 2341 | do i=1,nsing1 2342 | xltemp(i)=xmbase(nsing+i-1) 2343 | yltemp(i)=-yp1(nsing1-i+1) 2344 | end do 2345 | c shift all arrays so the y=0 is defined by model base on pro-side 2346 | yshift=ymbase(1)-plthick-athick 2347 | do i=1,ncol 2348 | ymbase(i)=ymbase(i)-yshift 2349 | ymtop(i)=ymtop(i)-yshift 2350 | end do 2351 | do i=1,nsing1 2352 | yltemp(i)=yltemp(i)-yshift 2353 | end do 2354 | end 2355 | 2356 | c####################################################################### 2357 | c find the closest node in the xdimension giving an x psoition 2358 | c####################################################################### 2359 | subroutine find_node(node,ntype,xwant,ncol,npad,xuse) 2360 | use dyn_arrays 2361 | implicit real*8 (a-h,o-z) 2362 | implicit integer (i-n) 2363 | 2364 | node=0 2365 | if(ntype.eq.0) then 2366 | node=int(xwant) 2367 | else 2368 | do i=1+npad,ncol+npad 2369 | if(xbase(i).gt.xwant) then 2370 | if(abs(xwant-xbase(i)).ge.abs(xwant-xbase(i-1))) then 2371 | node=i-1-npad 2372 | exit 2373 | else 2374 | node=i-npad 2375 | exit 2376 | endif 2377 | else if(xbase(i).eq.xwant) then 2378 | node=i-npad 2379 | exit 2380 | endif 2381 | end do 2382 | endif 2383 | xuse=xbase(node+npad) 2384 | end 2385 | 2386 | c #################################################################### 2387 | c output mesh and parameters 2388 | c##################################################################### 2389 | subroutine output(ncol,nerowm,ntrow,nsing,plvel,upvel, 2390 | *iunflag,iunbeg,vrig,beta,epsinv,rhof, 2391 | *rhom,iso,prigi,rrigi,sload,smomen,xadd,ctoler,wdepth,wtoler, 2392 | *numvebn,numpbn,numsid,numvtbn,ntst,delt,intout,intoutl,minint, 2393 | *maxint,npass,toler,erosl,erosr,peros,rpow,ntt2,deltt2,np1,np2, 2394 | *nsing1,npad,nplbase,npltop,plscale,rlscale,blscale,dfact,slpmax, 2395 | *tmax,nrowl,plthick,numvetbn,linflag,iplasflg,iblay,iblayt,isedl, 2396 | *isedr,iexflg,ibasflg,nbastary,nbastind,intmrkb,ipkfill,ibasfill, 2397 | *sedmax,ntbcs,noutput) 2398 | use dyn_arrays 2399 | implicit real*8(a-h,o-z) 2400 | implicit integer(i-n) 2401 | 2402 | open(3,file='input/mesh',position='rewind') 2403 | open(1,file='input/connections.dat',position='rewind') 2404 | c mech model (# nodes, # elements, l-mesh style) 2405 | nnodesm=ncol*nerowm 2406 | nelem=(ncol-1)*(nerowm-1) 2407 | write(3,102)nnodesm,nelem 2408 | c mech model (# rows/ colms of element verticies 2409 | write(3,102)nerowm,ncol 2410 | c lmesh parameters 2411 | write(3,103)plscale,rlscale,blscale,dfact 2412 | c thermal model (#nodes, # elements, # rows in lith) 2413 | nnodest=ncol*ntrow 2414 | nelet=(ncol-1)*(ntrow-1)*2 2415 | write(3,102)nnodest,nelet 2416 | write(3,102)ntrow,ncol,nrowl 2417 | c ref. thickness of lithosphere. used in thermal remeshing 2418 | write(3,103)plthick 2419 | c spoint node 2420 | write(3,102)nsing 2421 | c convergence and underplating velocity 2422 | write(3,119)plvel,upvel 2423 | c underplating parameter 2424 | if(iunflag.eq.2) iunflag=0 2425 | write(3,107)iunflag,iunbeg 2426 | c rigid visc 2427 | write(3,103)vrig 2428 | c compressibility, epsinv, tmax 2429 | write(3,103)beta,epsinv,tmax 2430 | c flag for using linear or non-linear eqns 2431 | write(3,102)linflag 2432 | c flag for allowing purely plastic def (no viscous) 2433 | write(3,102)iplasflg 2434 | c overlying fluid and mantle density 2435 | write(3,103)rhof,rhom 2436 | c flexural paramters 2437 | write(3,102)iso 2438 | write(3,103)prigi,rrigi,sload,smomen 2439 | write(3,103)xadd,ctoler,wdepth,wtoler 2440 | c if not outputting extension for plasti, change nsing1 and np1 2441 | if(iexflg.eq.1) then 2442 | write(3,102)np1-nsing1+1,np2,npad,1 2443 | else 2444 | write(3,102)np1,np2,npad,nsing1 2445 | endif 2446 | c number of boundary conditions 2447 | write(3,102)numvebn,numvetbn,numpbn,numsid,numvtbn 2448 | c number of timesteps, timestep length 2449 | write(3,104)ntst,delt 2450 | c output interval for all, output interval for lmesh 2451 | write(3,102)intout,intoutl 2452 | c min iter, max iter, # filtering passes, conv. toler. 2453 | write(3,109)minint,maxint,npass,toler 2454 | c erosion parameters 2455 | write(3,103)erosl,erosr,peros,rpow 2456 | c sedimentation parameters 2457 | write(3,112)ipkfill,ibasfill,isedl,isedr,sedmax 2458 | c basin tracking parameters 2459 | write(3,101)ibasflg,nbastary,nbastind,intmrkb 2460 | c maximum surface slope 2461 | write(3,103)slpmax 2462 | c thermal runup parameters 2463 | write(3,104)ntt2,deltt2 2464 | c number of bounadry layers 2465 | write(3,102)iblay,iblayt 2466 | c output variable mat. props 2467 | do i=1,nelem 2468 | write(3,113)rhoc(i),phi(i),coh(i),vmin(i),q(i),prex(i),expn(i) 2469 | end do 2470 | c output node coordinates 2471 | do i=1,nnodest 2472 | write(3,113)pos(i,1),pos(i,2) 2473 | end do 2474 | c output the slope on the lhs and rhs base 2475 | dx=pos(ntrow-nerowm+1,1)-pos(ntrow*2-nerowm+1,1) 2476 | dy=pos(ntrow-nerowm+1,2)-pos(ntrow*2-nerowm+1,2) 2477 | slp1=atan(dy/dx) 2478 | dx=pos(nnodest-nerowm+1,1)-pos(nnodest-ntrow-nerowm+1,1) 2479 | dy=pos(nnodest-nerowm+1,2)-pos(nnodest-ntrow-nerowm+1,2) 2480 | slp2=atan(dy/dx) 2481 | print*,'#### Slope at base of model (deg)' 2482 | print*,'#### lhs =',slp1*180.0/3.1416 2483 | print*,'#### rhs =',slp2*180.0/3.1416 2484 | c output node connections for mech model 2485 | do icol=1,ncol-1 2486 | do irow=1,nerowm-1 2487 | n1=(icol-1)*nerowm+irow 2488 | n2=n1+nerowm 2489 | n3=n2+1 2490 | n4=n1+1 2491 | write(3,102)n1,n2,n3,n4 2492 | end do 2493 | end do 2494 | c output boundary conditions 2495 | c velocity boundary conditions on model edges 2496 | index=0 2497 | if(numvebn.gt.0) then 2498 | c x and y vel 2499 | do i=1,numvebn 2500 | index=index+1 2501 | write(3,114)int(bc(1,index)),int(bc(2,index)),bc(3,index) 2502 | end do 2503 | end if 2504 | c pressure boudary conditions 2505 | if(numpbn.gt.0) then 2506 | do i=1,numpbn 2507 | index=index+1 2508 | write(3,115)int(bc(1,index)),bc(3,index) 2509 | end do 2510 | end if 2511 | c edge tangential vel boundary conditions 2512 | if(numvetbn.gt.0) then 2513 | do i=1,numvetbn 2514 | index=index+1 2515 | write(3,115)int(bc(1,index)),bc(2,index) 2516 | end do 2517 | endif 2518 | c basal tangential vel boundary conditions 2519 | if(numvtbn.gt.0) then 2520 | do i=1,numvtbn 2521 | index=index+1 2522 | write(3,115)int(bc(1,index)),bc(2,index),bc(3,index) 2523 | end do 2524 | endif 2525 | c THERMAL Output 2526 | c number of nodes, number of elements, number of domains, number of temp BCs 2527 | write(3,102)nnodest,nelet,5,ntbcs 2528 | c mesh connections 2529 | write(1,102)nelet 2530 | do icol=1,ncol-1 2531 | do irow=1,ntrow-1 2532 | n1=(icol-1)*(ntrow)+irow 2533 | n2=n1+ntrow 2534 | n3=n1+1 2535 | write(1,102)n1,n2,n3 2536 | n1=n1+1 2537 | n2=n2 2538 | n3=n2+1 2539 | write(1,102)n1,n2,n3 2540 | end do 2541 | end do 2542 | c domain definitions 2543 | do i=1,nelet 2544 | write(3,102)ndomain(i) 2545 | end do 2546 | c Variable properties 2547 | do i=1,nelet 2548 | write(3,113)therm_cond(i,1),therm_cond(i,2) 2549 | end do 2550 | do i=1,nelet 2551 | write(3,113)therm_rho(i) 2552 | end do 2553 | do i=1,nelet 2554 | write(3,113)spec_heat(i) 2555 | end do 2556 | do i=1,nelet 2557 | write(3,113)heat_prod(i) 2558 | end do 2559 | c BCs 2560 | c const temp nodes 2561 | do i=1,ntbcs 2562 | write(3,115)int(therm_bc(1,i)),therm_bc(2,i) 2563 | end do 2564 | 2565 | c output flexure arrays in x and y for use in isostacy calc in plasti 2566 | c if iexflg=1 do not ouput the extension for use in the plasti 2567 | c flexure calculation 2568 | if(iexflg.eq.1) then 2569 | do i=nsing1,np1 2570 | write(3,113)xp1(i)-xp1(nsing1),yp1(i),dyinit1(i) 2571 | end do 2572 | else 2573 | do i=1,np1 2574 | write(3,113)xp1(i),yp1(i),dyinit1(i) 2575 | end do 2576 | endif 2577 | do i=1,np2 2578 | write(3,113)xp2(i),yp2(i),dyinit1(i) 2579 | end do 2580 | c 2581 | c output file output flags 2582 | c 2583 | open(4,file='output/output_flags',position='rewind') 2584 | write(3,101)noutput 2585 | write(4,101)noutput 2586 | do i=1,noutput 2587 | write(3,101)output_flags(i) 2588 | write(4,101)output_flags(i) 2589 | end do 2590 | close(3) 2591 | close(4) 2592 | close(1) 2593 | 2594 | c output the node numbers of the domain boundaries 2595 | open(3,file='input/boundary_nodes.dat') 2596 | c top of mech model 2597 | write(3,102)ncol 2598 | do i=1,ncol 2599 | write(3,102)mecht_nodes(i) 2600 | end do 2601 | c base of mech model 2602 | write(3,102)ncol 2603 | do i=1,ncol 2604 | write(3,102)mechb_nodes(i) 2605 | end do 2606 | c base of pro lith 2607 | write(3,102)nplbase 2608 | do i=1,nplbase 2609 | write(3,102)plithb_nodes(i) 2610 | end do 2611 | c top of pro lith 2612 | write(3,102)npltop 2613 | do i=1,npltop 2614 | write(3,102)plitht_nodes(i) 2615 | end do 2616 | c base of retro lith 2617 | write(3,102)ncol-nsing 2618 | do i=1,ncol-nsing 2619 | write(3,102)rlithb_nodes(i) 2620 | end do 2621 | 2622 | 101 format(9i5) 2623 | 102 format(9i8) 2624 | 103 format(4e16.8) 2625 | 104 format(i5,2e16.8) 2626 | 107 format(i2,i4,e16.8) 2627 | 109 format(3i5,e16.8) 2628 | 112 format(4i5,e10.2) 2629 | 113 format(9e23.15) 2630 | 114 format(2i8,4e23.15) 2631 | 115 format(i8,4e23.15) 2632 | 119 format(2f8.1,e13.8) 2633 | end 2634 | 2635 | c###################################################### 2636 | c make array of variable tehrm properties 2637 | c###################################################### 2638 | subroutine mk_therm_para(ntrow,ncol,ntmchg,nrowl,nrowa, 2639 | *ntbcs,iflgcl,agecl,nplbase,npltop) 2640 | use dyn_arrays 2641 | implicit real*8 (a-h,o-z) 2642 | implicit integer (i-n) 2643 | real*4 arg 2644 | 2645 | C THERMAL BCs 2646 | c allocate space 2647 | if(iflgcl.eq.1) then 2648 | ntbcs=2*ncol+nplbase-npltop+ntrow-nrowa 2649 | allocate(therm_bc(2,ntbcs)) 2650 | else 2651 | ntbcs=2*ncol+nplbase-npltop 2652 | allocate(therm_bc(2,ntbcs)) 2653 | endif 2654 | c calculate the temp for 1-d,semi-infinite cooling lithos 2655 | index=0 2656 | if(iflgcl.eq.1) then 2657 | time=agecl*3.15578e13 2658 | rho=therm_prop(2,3) 2659 | cp=therm_prop(2,4) 2660 | tcond=therm_prop(2,2) 2661 | tsurf=thermbcs(1,1) 2662 | tmant=thermbcs(1,2) 2663 | ysurf=pos(ntrow,2) 2664 | do i=ntrow,nrowa,-1 2665 | index=index+1 2666 | depth=ysurf-pos(i,2) 2667 | arg=depth/(2.0*(tcond*time/(rho*cp))**(.5)) 2668 | temp=erfc(arg)*(tsurf-tmant)+tmant 2669 | therm_bc(1,index)=dble(i) 2670 | therm_bc(2,index)=temp 2671 | end do 2672 | print*,'## Temp in asthen: ',tmant 2673 | print*,'## Temp at Lith base: ',therm_bc(2,index) 2674 | endif 2675 | c temp at surface 2676 | do i=1,ncol 2677 | index=index+1 2678 | therm_bc(1,index)=dble(ntrow*i) 2679 | therm_bc(2,index)=thermbcs(1,1) 2680 | end do 2681 | c temp at base 2682 | do i=1,nplbase 2683 | index=index+1 2684 | therm_bc(1,index)=dble(1+(i-1)*ntrow) 2685 | therm_bc(2,index)=thermbcs(1,2) 2686 | end do 2687 | do i=npltop+1,ncol 2688 | index=index+1 2689 | therm_bc(1,index)=dble(1+(i-1)*ntrow) 2690 | therm_bc(2,index)=thermbcs(1,2) 2691 | end do 2692 | 2693 | C THERMAL PROPS 2694 | ntele=(ncol-1)*(ntrow-1)*2 2695 | allocate(therm_cond(ntele,2)) 2696 | allocate(therm_rho(ntele)) 2697 | allocate(spec_heat(ntele)) 2698 | allocate(heat_prod(ntele)) 2699 | c initial definitions from thermal domains 2700 | do i=1,ntele 2701 | therm_cond(i,1)=therm_prop(ndomain(i),1) 2702 | therm_cond(i,2)=therm_prop(ndomain(i),2) 2703 | therm_rho(i)=therm_prop(ndomain(i),3) 2704 | spec_heat(i)=therm_prop(ndomain(i),4) 2705 | heat_prod(i)=therm_prop(ndomain(i),5) 2706 | end do 2707 | c change in therm props in the mech model 2708 | do j=1,ntmchg 2709 | ibcol=int(tm_prop(j,1)) 2710 | iecol=int(tm_prop(j,2)) 2711 | ibrow=int(tm_prop(j,3)) 2712 | ierow=int(tm_prop(j,4)) 2713 | nele_row=(ntrow-1)*2 2714 | nele_al=(nrowa+nrowl)*2 2715 | do icol=ibcol,iecol 2716 | do irow=ibrow,ierow 2717 | iele1=nele_al+irow*2-1+(icol-1)*nele_row 2718 | iele2=nele_al+irow*2+(icol-1)*nele_row 2719 | therm_cond(iele1,1)=tm_prop(j,5) 2720 | therm_cond(iele2,1)=tm_prop(j,5) 2721 | therm_cond(iele1,2)=tm_prop(j,6) 2722 | therm_cond(iele2,2)=tm_prop(j,6) 2723 | therm_rho(iele1)=tm_prop(j,7) 2724 | therm_rho(iele2)=tm_prop(j,7) 2725 | spec_heat(iele1)=tm_prop(j,8) 2726 | spec_heat(iele2)=tm_prop(j,8) 2727 | heat_prod(iele1)=tm_prop(j,9) 2728 | heat_prod(iele2)=tm_prop(j,9) 2729 | end do 2730 | end do 2731 | end do 2732 | end 2733 | 2734 | c############################################################## 2735 | c output the domain boundaries for plotting 2736 | c############################################################## 2737 | subroutine bndry_output(wheight,ncol,npad,wdepth,np1,np2,yshift 2738 | *,nsing,nsing1,npltop,nrlbase,nplbase) 2739 | use dyn_arrays 2740 | implicit real*8 (a-h,o-z) 2741 | implicit integer (i-n) 2742 | 2743 | open(2,file='profiles/sealevel',action='write') 2744 | open(3,file='profiles/mech_top',action='write') 2745 | open(4,file='profiles/plith_top',action='write') 2746 | open(7,file='profiles/rlith_top',action='write') 2747 | open(8,file='profiles/plith_base',action='write') 2748 | open(9,file='profiles/rlith_base',action='write') 2749 | open(10,file='profiles/mech_base_slope',action='write') 2750 | open(11,file='profiles/mech_top_slope',action='write') 2751 | open(12,file='profiles/mech_base_slope_rise_run',action='write') 2752 | 2753 | c ccccccccccccccccccccccccccccccccccccccccccccccccccccccc 2754 | c output domains for plotting 2755 | c ccccccccccccccccccccccccccccccccccccccccccccccccccccccc 2756 | c output sealevel over extended model domain 2757 | wref=wheight-yshift 2758 | print*,'water height',wheight,yshift 2759 | if(wdepth.gt.0.0) then 2760 | do i=1,ncol+2*npad 2761 | write(2,113)xbase(i)/1000.0,(wheight-yshift-wref)/1000.0 2762 | end do 2763 | else 2764 | do i=1,ncol+2*npad 2765 | write(2,*)'0.0 0.0\n' 2766 | end do 2767 | endif 2768 | c output top of mech model over plate 1 extended model domain 2769 | index=0 2770 | do i=1,nsing+npad 2771 | ip=np1-i+1 2772 | index=index+1 2773 | write(3,113)xbase(i)/1000.0, 2774 | * (-yp1(ip)+dyinit1(ip)-yshift-wref)/1000.0 2775 | end do 2776 | c ouput slope of top/bottom of model plate 1 2777 | index2=npad 2778 | do i=npad+1,nsing+npad 2779 | index2=index2+1 2780 | ip=np1-i+1 2781 | dx=xbase(i)-xbase(i-1) 2782 | dy=(-yp1(ip)+dyinit1(ip))-(-yp1(ip+1)+dyinit1(ip+1)) 2783 | dy2=(-yp1(ip))-(-yp1(ip+1)) 2784 | slp=atan(dy/dx)*180.0/3.141592 2785 | slp2=atan(dy2/dx)*180.0/3.141592 2786 | slp3=dy2/dx 2787 | write(11,113)(xbase(i)-dabs(dx-2.0))/1000.0,slp 2788 | write(10,113)(xbase(i)-dabs(dx-2.0))/1000.0,slp2 2789 | write(12,113)(xbase(i)-dabs(dx-2.0))/1000.0,slp3 2790 | end do 2791 | c output top of mech model over plate 2 extended model domain 2792 | do i=1,np2 2793 | index=index+1 2794 | write(3,113)xbase(index-1)/1000.0, 2795 | * (-yp2(i)+dyinit2(i)-yshift-wref)/1000.0 2796 | end do 2797 | c output slope of top of model plate 2 2798 | do i=1,np2-npad 2799 | index2=index2+1 2800 | dx=xbase(index2-1)-xbase(index2) 2801 | dy=(-yp2(i)+dyinit2(i))-(-yp2(i+1)+dyinit2(i+1)) 2802 | dy2=(-yp2(i))-(-yp2(i+1)) 2803 | slp=atan(dy/dx)*180.0/3.141592 2804 | slp2=atan(dy2/dx)*180.0/3.141592 2805 | slp3=dy2/dx 2806 | write(11,113)(xbase(index2-1)+dabs(dx/2.0))/1000.0,slp 2807 | write(10,113)(xbase(index2-1)+dabs(dx/2.0))/1000.0,slp2 2808 | write(12,113)(xbase(index2-1)+dabs(dx/2.0))/1000.0,slp3 2809 | end do 2810 | c output top of pro-lithosphere to end of plate 1 2811 | do i=1,np1 2812 | ip=np1-i+1 2813 | write(4,113)xbase(i)/1000.0,(-yp1(ip)-yshift-wref)/1000.0 2814 | end do 2815 | c output top of pro-lith from end of plate 1 to model base 2816 | do i=np1+1,npltop+npad 2817 | write(4,113)xbase(i)/1000.0,(ypltop(i-npad)-wref)/1000.0 2818 | end do 2819 | c ouput top of retro lith 2820 | do i=1,np2 2821 | write(7,113)xbase(nsing-1+i+npad)/1000.0, 2822 | * (-yp2(i)-yshift-wref)/1000.0 2823 | end do 2824 | c output base of pro-lith 2825 | do i=1,nplbase 2826 | write(8,113)xmbase(i)/1000.0,(yplbase(i)-wref)/1000.0 2827 | end do 2828 | c output base of retro-lith 2829 | do i=1,nrlbase 2830 | write(9,113)xrlbase(i)/1000.0,(yrlbase(i)-wref)/1000.0 2831 | end do 2832 | 2833 | print*,' Y pos of coupling point relative to sea level (km)' 2834 | *,(-yp2(1)-yshift-wref)/1000.0 2835 | 2836 | close(2);close(3);close(4);close(7);close(8);close(9) 2837 | close(10);close(11);close(12) 2838 | 113 format(4e16.8) 2839 | end 2840 | 2841 | c########################################################### 2842 | c make initial profiles from circular arcs defined by rigid 2843 | c########################################################### 2844 | 2845 | subroutine arc_prof(nerowm,ncol,np1,np2,prigp,rrigp,rhom, 2846 | *npad,nsing,nsing1,wdepth,ypmbase,yrmbase,wheight,inflag, 2847 | *dyc,itrench,sdip) 2848 | 2849 | use dyn_arrays 2850 | implicit real*8 (a-h,o-z) 2851 | implicit integer (i-n) 2852 | 2853 | c slab dip in radians 2854 | sdip=sdip*3.141592/180.0 2855 | c flexural parameters 2856 | g=9.8 2857 | alpha1=(4.0*prigp/((rhom)*g))**0.25 2858 | alpha2=(4.0*rrigp/((rhom)*g))**0.25 2859 | c define curvature radius as function of flexural parameter 2860 | rad1=3.141592*alpha1/2.0 2861 | rad2=3.141592*alpha2/2.0 2862 | 2863 | C PLATE 1 2864 | c define initial depth from offsets in plates between model edge 2865 | c and the trench (begining of arc) 2866 | itrench1=np1-(itrench+npad)+1 2867 | do i=itrench1,np1 2868 | yp1(i)=-ypmbase 2869 | end do 2870 | c set depth from trench landward from circular arc till prescribed 2871 | c dip is reached 2872 | icatch=0 2873 | c define center of arc(xnot,ynot) 2874 | xnot=xp1(itrench1) 2875 | ynot=-ypmbase-rad1 2876 | c calculate arc 2877 | do i=itrench1-1,1,-1 2878 | yp1(i)=ynot+dsqrt(rad1**2-(xp1(i)-xnot)**2) 2879 | dip=datan((yp1(i+1)-yp1(i))/(xp1(i+1)-xp1(i))) 2880 | if(dip.gt.sdip) then 2881 | icatch=1 2882 | exit 2883 | endif 2884 | end do 2885 | if(icatch.eq.0) then 2886 | print*,'ERROR: circular arc on pro side did not reach sdip' 2887 | print*,' increase the length of the extension' 2888 | call profdump(xbase,-yp1,-yp2,np1,np2,nsing,npad) 2889 | stop 2890 | endif 2891 | c set remaining with prescribed slope 2892 | do j=i,1,-1 2893 | yp1(j)=yp1(j+1)-(xp1(j+1)-xp1(j))*dtan(sdip) 2894 | end do 2895 | 2896 | C PLATE 2 2897 | c check that plate two is not below the level of the spoint, this 2898 | c is not a valid solution 2899 | if(yp1(nsing1).gt.-yrmbase) then 2900 | print*,'ERROR: the elevation of plate 2 is below the spoint' 2901 | print*,' could increase slab dip, decrease plate offset,' 2902 | print*,' do anything to lower the level of spoint.' 2903 | print*,' y(s)=',yp1(nsing1),'y plate 2=',-yrmbase 2904 | yp2(1)=yp1(nsing1) 2905 | do i=1,np2 2906 | yp2(i)=-yrmbase 2907 | end do 2908 | call profdump(xbase,-yp1,-yp2,np1,np2,nsing,npad) 2909 | stop 2910 | endif 2911 | c define center of arc for plate 2 (xnot,ynot) 2912 | xnot=dsqrt(rad2**2-(-rad2-yp1(nsing1)-yrmbase)**2) 2913 | ynot=-rad2-yrmbase 2914 | yp2(1)=yp1(nsing1) 2915 | icatch=0 2916 | c calculate arc 2917 | do i=2,np2 2918 | yp2(i)=ynot+dsqrt(rad2**2-(xp2(i)-xnot)**2) 2919 | if(xp2(i).ge.xnot) then 2920 | icatch=1 2921 | exit 2922 | endif 2923 | end do 2924 | if(icatch.eq.0) then 2925 | print*,'ERROR: circular arc on retro side did not reach zero' 2926 | print*,' slope.' 2927 | call profdump(xbase,yp1,yp2,np1,np2,nsing,npad) 2928 | stop 2929 | endif 2930 | c set remaining with initial position 2931 | do j=i,np2 2932 | yp2(j)=-yrmbase 2933 | end do 2934 | 2935 | c switch sign so that deflections down are positive 2936 | yp2=yp2*(-1.0) 2937 | yp1=yp1*(-1.0) 2938 | 2939 | c set water height for plotting 2940 | wheight=-yp1(np1-npad)+dyinit1(np1-npad)+wdepth 2941 | 2942 | end 2943 | 2944 | 2945 | --------------------------------------------------------------------------------